diff --git a/Makefile b/Makefile index a17481c2..f5bb99bc 100644 --- a/Makefile +++ b/Makefile @@ -7,7 +7,7 @@ library: libdir mlp libdir: (if test ! -d lib ; then mkdir lib; fi) mlp: - cd mlprec && $(MAKE) lib + cd mlprec && $(MAKE) all install: all (./mkdir.sh $(INSTALL_DIR) &&\ diff --git a/mlprec/Makefile b/mlprec/Makefile index 9b5dfead..48bd7ffd 100644 --- a/mlprec/Makefile +++ b/mlprec/Makefile @@ -89,31 +89,31 @@ COBJS= mld_sslu_interface.o mld_sumf_interface.o \ mld_cslu_interface.o mld_cumf_interface.o \ mld_zslu_interface.o mld_zumf_interface.o -OBJS=$(F90OBJS) $(MODOBJS) $(COBJS) $(MPCOBJS) +OBJS=$(MODOBJS) +#OBJS=$(F90OBJS) $(MODOBJS) $(COBJS) $(MPCOBJS) LIBMOD=mld_prec_mod$(.mod) LOCAL_MODS=$(MODOBJS:.o=$(.mod)) LIBNAME=libmld_prec.a -lib: $(LIBDIR)/$(LIBNAME) +all: lib impld -$(LIBNAME): $(OBJS) +impld: $(OBJS) + cd impl && $(MAKE) + +lib: $(OBJS) impld $(AR) $(HERE)/$(LIBNAME) $(OBJS) $(RANLIB) $(HERE)/$(LIBNAME) - - -# flea: if libdir misses some .mod file, it won't be copied unless the .a file is missing too -$(LIBDIR)/$(LIBNAME): $(LIBNAME) /bin/cp -p $(HERE)/$(LIBNAME) $(LIBDIR) /bin/cp -p $(LIBMOD) $(LOCAL_MODS) mld_const.h $(LIBDIR) -mld_s_prec_type.o mld_d_prec_type.o mld_c_prec_type.o mld_z_prec_type.o : mld_base_prec_type.o -mld_prec_type.o: mld_s_prec_type.o mld_d_prec_type.o mld_c_prec_type.o mld_z_prec_type.o -mld_prec_mod.o: mld_prec_type.o mld_s_prec_mod.o mld_d_prec_mod.o mld_c_prec_mod.o mld_z_prec_mod.o $(MODOBJS): $(PSBINCDIR)/psb_base_mod$(.mod) mld_base_prec_type.o: mld_const.h +mld_s_prec_type.o mld_d_prec_type.o mld_c_prec_type.o mld_z_prec_type.o : mld_base_prec_type.o +mld_prec_type.o: mld_s_prec_type.o mld_d_prec_type.o mld_c_prec_type.o mld_z_prec_type.o +mld_prec_mod.o: mld_prec_type.o mld_s_prec_mod.o mld_d_prec_mod.o mld_c_prec_mod.o mld_z_prec_mod.o $(SINNEROBJS) $(SOUTEROBJS): $(SMODOBJS) $(DINNEROBJS) $(DOUTEROBJS): $(DMODOBJS) @@ -200,14 +200,11 @@ mld_cprecinit.o mld_cprecset.o: mld_c_diag_solver.o mld_c_ilu_solver.o \ - -mpobjs: $(MODOBJS) - (make $(MPFOBJS) F90="$(MPF90)" F90COPT="$(F90COPT)") - (make $(MPCOBJS) CC="$(MPCC)" CCOPT="$(CCOPT)") - veryclean: clean /bin/rm -f $(LIBNAME) -clean: +clean: implclean /bin/rm -f $(OBJS) $(LOCAL_MODS) +implclean: + cd impl && $(MAKE) clean \ No newline at end of file diff --git a/mlprec/impl/Makefile b/mlprec/impl/Makefile new file mode 100644 index 00000000..49fce95a --- /dev/null +++ b/mlprec/impl/Makefile @@ -0,0 +1,87 @@ +include ../../Make.inc +LIBDIR=../../lib +PSBLIBDIR=$(PSBLASDIR)/lib +PSBINCDIR=$(PSBLASDIR)/include +HERE=.. + +FINCLUDES=$(FMFLAG).. $(FMFLAG)$(LIBDIR) $(FMFLAG)$(PSBINCDIR) $(FMFLAG)$(PSBLIBDIR) + + +DMPFOBJS=mld_daggrmat_nosmth_asb.o mld_daggrmat_smth_asb.o mld_daggrmat_minnrg_asb.o + +SMPFOBJS=mld_saggrmat_nosmth_asb.o mld_saggrmat_smth_asb.o mld_saggrmat_minnrg_asb.o + +ZMPFOBJS=mld_zaggrmat_nosmth_asb.o mld_zaggrmat_smth_asb.o mld_zaggrmat_minnrg_asb.o + +CMPFOBJS=mld_caggrmat_nosmth_asb.o mld_caggrmat_smth_asb.o mld_caggrmat_minnrg_asb.o + + +MPFOBJS=$(SMPFOBJS) $(DMPFOBJS) $(CMPFOBJS) $(ZMPFOBJS) + +MPCOBJS=mld_sslud_interface.o mld_dslud_interface.o mld_cslud_interface.o mld_zslud_interface.o + + +DINNEROBJS= mld_dcoarse_bld.o mld_dmlprec_bld.o \ + mld_dilu0_fact.o mld_diluk_fact.o mld_dilut_fact.o mld_daggrmap_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 + +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 + +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 + +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 + + +INNEROBJS= $(SINNEROBJS) $(DINNEROBJS) $(CINNEROBJS) $(ZINNEROBJS) + + +DOUTEROBJS=mld_dprecbld.o mld_dprecset.o mld_dprecinit.o mld_dprecaply.o + +SOUTEROBJS=mld_sprecbld.o mld_sprecset.o mld_sprecinit.o mld_sprecaply.o + +ZOUTEROBJS=mld_zprecbld.o mld_zprecset.o mld_zprecinit.o mld_zprecaply.o + +COUTEROBJS=mld_cprecbld.o mld_cprecset.o mld_cprecinit.o mld_cprecaply.o + + +OUTEROBJS=$(SOUTEROBJS) $(DOUTEROBJS) $(COUTEROBJS) $(ZOUTEROBJS) + +F90OBJS=$(OUTEROBJS) $(INNEROBJS) + +COBJS= mld_sslu_interface.o mld_sumf_interface.o \ + mld_dslu_interface.o mld_dumf_interface.o \ + mld_cslu_interface.o mld_cumf_interface.o \ + mld_zslu_interface.o mld_zumf_interface.o + +OBJS=$(F90OBJS) $(COBJS) $(MPCOBJS) + +LIBNAME=libmld_prec.a + +lib: $(OBJS) + $(AR) $(HERE)/$(LIBNAME) $(OBJS) + $(RANLIB) $(HERE)/$(LIBNAME) + +mpobjs: + (make $(MPFOBJS) F90="$(MPF90)" F90COPT="$(F90COPT)") + (make $(MPCOBJS) CC="$(MPCC)" CCOPT="$(CCOPT)") + +veryclean: clean + /bin/rm -f $(LIBNAME) + +clean: + /bin/rm -f $(OBJS) $(LOCAL_MODS) + diff --git a/mlprec/impl/mld_c_as_smoother_impl.f90 b/mlprec/impl/mld_c_as_smoother_impl.f90 new file mode 100644 index 00000000..da39bdbc --- /dev/null +++ b/mlprec/impl/mld_c_as_smoother_impl.f90 @@ -0,0 +1,1344 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) +!!$ +!!$ (C) Copyright 2008,2009,2010, 2010 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the MLD2P4 group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! +! +! +! +! + +subroutine mld_c_as_smoother_check(sm,info) + + use psb_base_mod + use mld_c_as_smoother, mld_protect_nam => mld_c_as_smoother_check + + Implicit None + + ! Arguments + class(mld_c_as_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='c_as_smoother_check' + + call psb_erractionsave(err_act) + info = psb_success_ + + call mld_check_def(sm%restr,& + & 'Restrictor',psb_halo_,is_legal_restrict) + call mld_check_def(sm%prol,& + & 'Prolongator',psb_none_,is_legal_prolong) + call mld_check_def(sm%novr,& + & 'Overlap layers ',0,is_legal_n_ovr) + + + if (allocated(sm%sv)) then + call sm%sv%check(info) + else + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + if (info /= psb_success_) goto 9999 + + 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 mld_c_as_smoother_check + +subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + use psb_base_mod + use mld_c_as_smoother, mld_protect_nam => mld_c_as_smoother_apply_vect + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_c_as_smoother_type), intent(inout) :: sm + type(psb_c_vect_type),intent(inout) :: x + type(psb_c_vect_type),intent(inout) :: y + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + integer, intent(in) :: sweeps + complex(psb_spk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + + integer :: n_row,n_col, nrow_d, i + complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_spk_), allocatable :: vx(:) + type(psb_c_vect_type) :: vtx, vty, vww + integer :: ictxt,np,me, err_act,isz,int_err(5) + character :: trans_ + character(len=20) :: name='c_as_smoother_apply', ch_err + + call psb_erractionsave(err_act) + + info = psb_success_ + ictxt = desc_data%get_context() + call psb_info(ictxt,me,np) + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T') + case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + if (.not.allocated(sm%sv)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + + n_row = sm%desc_data%get_local_rows() + n_col = sm%desc_data%get_local_cols() + nrow_d = desc_data%get_local_rows() + isz = max(n_row,N_COL) + + if ((6*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + aux => work(3*isz+1:) + else if ((4*isz) <= size(work)) then + aux => work(1:) + allocate(ww(isz),tx(isz),ty(isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + else if ((3*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + allocate(aux(4*isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + else + allocate(ww(isz),tx(isz),ty(isz),& + &aux(4*isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + endif + + if ((sm%novr == 0).and.(sweeps == 1)) then + ! + ! Shortcut: in this case it's just the same + ! as Block Jacobi. + ! + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + else + + + vx = x%get_vect() + + call psb_geall(vtx,sm%desc_data,info) + call psb_geasb(vtx,sm%desc_data,info,mold=x%v) + call psb_geall(vty,sm%desc_data,info) + call psb_geasb(vty,sm%desc_data,info,mold=x%v) + call psb_geall(vww,sm%desc_data,info) + call psb_geasb(vww,sm%desc_data,info,mold=x%v) + call vtx%set(czero) + call vty%set(czero) + call vww%set(czero) + + + call vtx%set(vx(1:nrow_d)) + + if (sweeps == 1) then + + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx == x) + ! + if (sm%restr == psb_halo_) then + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (sm%prol) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(vtx,sm%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + call sm%sv%apply(cone,vtx,czero,vty,sm%desc_data,trans_,aux,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + select case(trans_) + case('N') + + select case (sm%prol) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,sm%desc_data,info,& + ! & update=sm%prol,work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(vty,sm%desc_data,info,& + & update=sm%prol,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + if (sm%restr == psb_halo_) then + call psb_ovrl(vty,sm%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + + + else if (sweeps > 1) then + + ! + ! + ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver + ! to compute an approximate solution of a linear system. + ! + ! + call vty%set(czero) + + do i=1, sweeps + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx == x) + ! + if (sm%restr == psb_halo_) then + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (sm%prol) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(vtx,sm%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + call psb_geaxpby(cone,vtx,czero,vww,sm%desc_data,info) + call psb_spmm(-cone,sm%nd,vty,cone,vww,sm%desc_data,info,& + & work=aux,trans=trans_) + + if (info /= psb_success_) exit + + call sm%sv%apply(cone,vww,czero,vty,sm%desc_data,trans_,aux,info) + + if (info /= psb_success_) exit + + + select case(trans_) + case('N') + + select case (sm%prol) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,sm%desc_data,info,& + ! & update=sm%prol,work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(vty,sm%desc_data,info,& + & update=sm%prol,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + if (sm%restr == psb_halo_) then + call psb_ovrl(vty,sm%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + end do + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + + else + + info = psb_err_iarg_neg_ + call psb_errpush(info,name,& + & i_err=(/2,sweeps,0,0,0/)) + goto 9999 + + + end if + + ! + ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) + ! + call psb_geaxpby(alpha,vty,beta,y,desc_data,info) + + end if + + + if ((6*isz) <= size(work)) then + else if ((4*isz) <= size(work)) then + deallocate(ww,tx,ty) + else if ((3*isz) <= size(work)) then + deallocate(aux) + else + deallocate(ww,aux,tx,ty) + endif + call vww%free(info) + call vtx%free(info) + call vty%free(info) + + 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 mld_c_as_smoother_apply_vect + + +subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + use psb_base_mod + use mld_c_as_smoother, mld_protect_nam => mld_c_as_smoother_apply + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_c_as_smoother_type), intent(in) :: sm + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + integer, intent(in) :: sweeps + complex(psb_spk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + + integer :: n_row,n_col, nrow_d, i + complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me, err_act,isz,int_err(5) + character :: trans_ + character(len=20) :: name='c_as_smoother_apply', ch_err + + call psb_erractionsave(err_act) + + info = psb_success_ + ictxt = desc_data%get_context() + call psb_info (ictxt,me,np) + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T') + case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + if (.not.allocated(sm%sv)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + + n_row = sm%desc_data%get_local_rows() + n_col = sm%desc_data%get_local_cols() + nrow_d = desc_data%get_local_rows() + isz=max(n_row,N_COL) + if ((6*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + aux => work(3*isz+1:) + else if ((4*isz) <= size(work)) then + aux => work(1:) + allocate(ww(isz),tx(isz),ty(isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + else if ((3*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + allocate(aux(4*isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + else + allocate(ww(isz),tx(isz),ty(isz),& + &aux(4*isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + endif + + if ((sm%novr == 0).and.(sweeps == 1)) then + ! + ! Shortcut: in this case it's just the same + ! as Block Jacobi. + ! + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + else + + + tx(1:nrow_d) = x(1:nrow_d) + tx(nrow_d+1:isz) = czero + + + if (sweeps == 1) then + + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx == x) + ! + if (sm%restr == psb_halo_) then + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (sm%prol) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(tx,sm%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + call sm%sv%apply(cone,tx,czero,ty,sm%desc_data,trans_,aux,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + select case(trans_) + case('N') + + select case (sm%prol) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,sm%desc_data,info,& + ! & update=sm%prol,work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(ty,sm%desc_data,info,& + & update=sm%prol,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + if (sm%restr == psb_halo_) then + call psb_ovrl(ty,sm%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + + + else if (sweeps > 1) then + + ! + ! + ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver + ! to compute an approximate solution of a linear system. + ! + ! + ty = czero + do i=1, sweeps + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx == x) + ! + if (sm%restr == psb_halo_) then + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (sm%prol) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(tx,sm%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + ww(1:n_row) = tx(1:n_row) + call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,work=aux,trans=trans_) + + if (info /= psb_success_) exit + + call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info) + + if (info /= psb_success_) exit + + + select case(trans_) + case('N') + + select case (sm%prol) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,sm%desc_data,info,& + ! & update=sm%prol,work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(ty,sm%desc_data,info,& + & update=sm%prol,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + if (sm%restr == psb_halo_) then + call psb_ovrl(ty,sm%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + end do + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + + else + + info = psb_err_iarg_neg_ + call psb_errpush(info,name,& + & i_err=(/2,sweeps,0,0,0/)) + goto 9999 + + + end if + + ! + ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) + ! + call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + + end if + + + if ((6*isz) <= size(work)) then + else if ((4*isz) <= size(work)) then + deallocate(ww,tx,ty) + else if ((3*isz) <= size(work)) then + deallocate(aux) + else + deallocate(ww,aux,tx,ty) + endif + + 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 mld_c_as_smoother_apply + +subroutine mld_c_as_smoother_bld(a,desc_a,sm,upd,info,amold,vmold) + use psb_base_mod + use mld_c_as_smoother, mld_protect_nam => mld_c_as_smoother_bld + Implicit None + + ! Arguments + type(psb_cspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_c_as_smoother_type), intent(inout) :: sm + character, intent(in) :: upd + integer, intent(out) :: info + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + + ! Local variables + type(psb_cspmat_type) :: blck, atmp + integer :: n_row,n_col, nrow_a, nhalo, novr, data_, nzeros + complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='c_as_smoother_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + novr = sm%novr + if (novr < 0) then + info=psb_err_invalid_ovr_num_ + call psb_errpush(info,name,i_err=(/novr,0,0,0,0,0/)) + goto 9999 + endif + + if ((novr == 0).or.(np == 1)) then + if (psb_toupper(upd) == 'F') then + call psb_cdcpy(desc_a,sm%desc_data,info) + If(debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' done cdcpy' + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Early return: P>=3 N_OVR=0' + endif + call blck%csall(0,0,info,1) + else + + If (psb_toupper(upd) == 'F') Then + ! + ! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_). + ! This is done by psb_cdbldext (interface to psb_cdovr), which is + ! independent of CSR, and has been placed in the tools directory + ! of PSBLAS, instead of the mlprec directory of MLD2P4, because it + ! might be used independently of the AS preconditioner, to build + ! a descriptor for an extended stencil in a PDE solver. + ! + call psb_cdbldext(a,desc_a,novr,sm%desc_data,info,extype=psb_ovt_asov_) + if(debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' From cdbldext _:',sm%desc_data%get_local_rows(),& + & sm%desc_data%get_local_cols() + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_cdbldext' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + Endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Before sphalo ' + + ! + ! Retrieve the remote sparse matrix rows required for the AS extended + ! matrix + data_ = psb_comm_ext_ + Call psb_sphalo(a,sm%desc_data,blck,info,data=data_,rowscale=.true.) + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sphalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (debug_level >=psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'After psb_sphalo ',& + & blck%get_nrows(), blck%get_nzeros() + + End if + if (info == psb_success_) & + & call sm%sv%build(a,sm%desc_data,upd,info,& + & blck,amold=amold,vmold=vmold) + + nrow_a = a%get_nrows() + n_row = sm%desc_data%get_local_rows() + n_col = sm%desc_data%get_local_cols() + + if (info == psb_success_) call a%csclip(sm%nd,info,& + & jmin=nrow_a+1,rscale=.false.,cscale=.false.) + if (info == psb_success_) call blck%csclip(atmp,info,& + & jmin=nrow_a+1,rscale=.false.,cscale=.false.) + if (info == psb_success_) call psb_rwextd(n_row,sm%nd,info,b=atmp) + + if (info == psb_success_) then + if (present(amold)) then + call sm%nd%cscnv(info,& + & mold=amold,dupl=psb_dupl_add_) + else + call sm%nd%cscnv(info,& + & type='csr',dupl=psb_dupl_add_) + end if + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4') + goto 9999 + end if + nzeros = sm%nd%get_nzeros() +!!$ write(0,*) me,' ND nzeors ',nzeros + call psb_sum(ictxt,nzeros) + sm%nd_nnz_tot = nzeros + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + 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 mld_c_as_smoother_bld + + +subroutine mld_c_as_smoother_seti(sm,what,val,info) + use psb_base_mod + use mld_c_as_smoother, mld_protect_nam => mld_c_as_smoother_seti + Implicit None + + ! Arguments + class(mld_c_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='c_as_smoother_seti' + + info = psb_success_ + 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_) + sm%restr = val + case(mld_sub_prol_) + sm%prol = 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 mld_c_as_smoother_seti + +subroutine mld_c_as_smoother_setc(sm,what,val,info) + use psb_base_mod + use mld_c_as_smoother, mld_protect_nam => mld_c_as_smoother_setc + Implicit None + ! Arguments + class(mld_c_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + character(len=*), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, ival + character(len=20) :: name='c_as_smoother_setc' + + info = psb_success_ + call psb_erractionsave(err_act) + + + call mld_stringval(val,ival,info) + if (info == psb_success_) call sm%set(what,ival,info) + 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 mld_c_as_smoother_setc + +subroutine mld_c_as_smoother_setr(sm,what,val,info) + use psb_base_mod + use mld_c_as_smoother, mld_protect_nam => mld_c_as_smoother_setr + Implicit None + ! Arguments + class(mld_c_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='c_as_smoother_setr' + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (allocated(sm%sv)) then + call sm%sv%set(what,val,info) + else +!!$ write(0,*) trim(name),' Missing component, not setting!' +!!$ info = 1121 + 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 mld_c_as_smoother_setr + +subroutine mld_c_as_smoother_free(sm,info) + use psb_base_mod + use mld_c_as_smoother, mld_protect_nam => mld_c_as_smoother_free + Implicit None + ! Arguments + class(mld_c_as_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='c_as_smoother_free' + + call psb_erractionsave(err_act) + info = psb_success_ + + + + if (allocated(sm%sv)) then + call sm%sv%free(info) + if (info == psb_success_) deallocate(sm%sv,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + end if + call sm%nd%free() + + 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 mld_c_as_smoother_free + +subroutine mld_c_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) + use psb_base_mod + use mld_c_as_smoother, mld_protect_nam => mld_c_as_smoother_dmp + implicit none + class(mld_c_as_smoother_type), intent(in) :: sm + integer, intent(in) :: ictxt,level + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: smoother, solver + integer :: i, j, il1, iln, lname, lev + integer :: icontxt,iam, np + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + logical :: smoother_ + ! len of prefix_ + + info = 0 + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_smth_c" + end if + + call psb_info(ictxt,iam,np) + + if (present(smoother)) then + smoother_ = smoother + else + smoother_ = .false. + end if + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + + if (smoother_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx' + if (sm%nd%is_asb()) & + & call sm%nd%print(fname,head=head) + end if + ! At base level do nothing for the smoother + if (allocated(sm%sv)) & + & call sm%sv%dump(ictxt,level,info,solver=solver) + +end subroutine mld_c_as_smoother_dmp + diff --git a/mlprec/mld_c_base_smoother_impl.f90 b/mlprec/impl/mld_c_base_smoother_impl.f90 similarity index 99% rename from mlprec/mld_c_base_smoother_impl.f90 rename to mlprec/impl/mld_c_base_smoother_impl.f90 index 5afbe59b..af9ecdb6 100644 --- a/mlprec/mld_c_base_smoother_impl.f90 +++ b/mlprec/impl/mld_c_base_smoother_impl.f90 @@ -341,7 +341,7 @@ end subroutine mld_c_base_smoother_bld ! subroutine mld_c_base_smoother_free(sm,info) use psb_base_mod - use mld_c_base_smoother_mod, mld_protect_name => s + use mld_c_base_smoother_mod, mld_protect_name => mld_c_base_smoother_free Implicit None ! Arguments diff --git a/mlprec/mld_c_base_solver_impl.f90 b/mlprec/impl/mld_c_base_solver_impl.f90 similarity index 100% rename from mlprec/mld_c_base_solver_impl.f90 rename to mlprec/impl/mld_c_base_solver_impl.f90 diff --git a/mlprec/mld_c_dec_map_bld.F90 b/mlprec/impl/mld_c_dec_map_bld.F90 similarity index 100% rename from mlprec/mld_c_dec_map_bld.F90 rename to mlprec/impl/mld_c_dec_map_bld.F90 diff --git a/mlprec/mld_c_onelev_impl.f90 b/mlprec/impl/mld_c_onelev_impl.f90 similarity index 93% rename from mlprec/mld_c_onelev_impl.f90 rename to mlprec/impl/mld_c_onelev_impl.f90 index 71a20088..d3be182f 100644 --- a/mlprec/mld_c_onelev_impl.f90 +++ b/mlprec/impl/mld_c_onelev_impl.f90 @@ -57,10 +57,10 @@ ! subroutine mld_c_base_onelev_descr(lv,il,nl,info,iout) use psb_base_mod - use mld_conelev_mod, mld_protect_name => mld_c_base_onelev_descr + use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_descr Implicit None ! Arguments - class(mld_conelev_type), intent(in) :: lv + class(mld_c_onelev_type), intent(in) :: lv integer, intent(in) :: il,nl integer, intent(out) :: info integer, intent(in), optional :: iout @@ -137,10 +137,10 @@ end subroutine mld_c_base_onelev_descr ! subroutine mld_c_base_onelev_free(lv,info) use psb_base_mod - use mld_conelev_mod, mld_protect_name =>: mld_T_onelev_precfree + use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_free implicit none - class(mld_conelev_type), intent(inout) :: lv + class(mld_c_onelev_type), intent(inout) :: lv integer, intent(out) :: info integer :: i @@ -175,12 +175,12 @@ end subroutine mld_c_base_onelev_free ! subroutine mld_c_base_onelev_check(lv,info) use psb_base_mod - use mld_conelev_mod, mld_protect_name => mld_c_base_onelev_check + use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_check Implicit None ! Arguments - class(mld_conelev_type), intent(inout) :: lv + class(mld_c_onelev_type), intent(inout) :: lv integer, intent(out) :: info Integer :: err_act character(len=20) :: name='c_base_onelev_check' @@ -231,12 +231,12 @@ end subroutine mld_c_base_onelev_check ! subroutine mld_c_base_onelev_seti(lv,what,val,info) use psb_base_mod - use mld_conelev_mod, mld_protect_name => mld_c_base_onelev_seti + use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_seti Implicit None ! Arguments - class(mld_conelev_type), intent(inout) :: lv + class(mld_c_onelev_type), intent(inout) :: lv integer, intent(in) :: what integer, intent(in) :: val integer, intent(out) :: info @@ -306,12 +306,12 @@ end subroutine mld_c_base_onelev_seti subroutine mld_c_base_onelev_setc(lv,what,val,info) use psb_base_mod - use mld_conelev_mod, mld_protect_name => mld_c_base_onelev_setc + use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_setc Implicit None ! Arguments - class(mld_conelev_type), intent(inout) :: lv + class(mld_c_onelev_type), intent(inout) :: lv integer, intent(in) :: what character(len=*), intent(in) :: val integer, intent(out) :: info @@ -342,12 +342,12 @@ end subroutine mld_c_base_onelev_setc subroutine mld_c_base_onelev_setr(lv,what,val,info) use psb_base_mod - use mld_conelev_mod, mld_protect_name => mld_c_base_onelev_setr + use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_setr Implicit None ! Arguments - class(mld_conelev_type), intent(inout) :: lv + class(mld_c_onelev_type), intent(inout) :: lv integer, intent(in) :: what real(psb_spk_), intent(in) :: val integer, intent(out) :: info @@ -392,9 +392,9 @@ end subroutine mld_c_base_onelev_setr ! subroutine mld_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver) use psb_base_mod - use mld_conelev_mod, mld_protect_name => mld_c_base_onelev_dump + use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_dump implicit none - class(mld_conelev_type), intent(in) :: lv + class(mld_c_onelev_type), intent(in) :: lv integer, intent(in) :: level integer, intent(out) :: info character(len=*), intent(in), optional :: prefix, head diff --git a/mlprec/mld_caggrmap_bld.f90 b/mlprec/impl/mld_caggrmap_bld.f90 similarity index 100% rename from mlprec/mld_caggrmap_bld.f90 rename to mlprec/impl/mld_caggrmap_bld.f90 diff --git a/mlprec/mld_caggrmat_asb.f90 b/mlprec/impl/mld_caggrmat_asb.f90 similarity index 98% rename from mlprec/mld_caggrmat_asb.f90 rename to mlprec/impl/mld_caggrmat_asb.f90 index 296158db..4b9637f7 100644 --- a/mlprec/mld_caggrmat_asb.f90 +++ b/mlprec/impl/mld_caggrmat_asb.f90 @@ -83,7 +83,7 @@ ! the fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of the fine-level matrix. -! p - type(mld_conelev_type), input/output. +! p - type(mld_c_onelev_type), input/output. ! The 'one-level' data structure that will contain the local ! part of the matrix to be built as well as the information ! concerning the prolongator and its transpose. @@ -109,7 +109,7 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_conelev_type), intent(inout), target :: p + type(mld_c_onelev_type), intent(inout), target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_caggrmat_minnrg_asb.F90 b/mlprec/impl/mld_caggrmat_minnrg_asb.F90 similarity index 99% rename from mlprec/mld_caggrmat_minnrg_asb.F90 rename to mlprec/impl/mld_caggrmat_minnrg_asb.F90 index 7397e5e1..5020b934 100644 --- a/mlprec/mld_caggrmat_minnrg_asb.F90 +++ b/mlprec/impl/mld_caggrmat_minnrg_asb.F90 @@ -83,7 +83,7 @@ ! the fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of the fine-level matrix. -! p - type(mld_conelev_type), input/output. +! p - type(mld_c_onelev_type), input/output. ! The 'one-level' data structure that will contain the local ! part of the matrix to be built as well as the information ! concerning the prolongator and its transpose. @@ -114,7 +114,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_conelev_type), intent(inout), target :: p + type(mld_c_onelev_type), intent(inout), target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_caggrmat_nosmth_asb.F90 b/mlprec/impl/mld_caggrmat_nosmth_asb.F90 similarity index 98% rename from mlprec/mld_caggrmat_nosmth_asb.F90 rename to mlprec/impl/mld_caggrmat_nosmth_asb.F90 index 66171166..1a6658d1 100644 --- a/mlprec/mld_caggrmat_nosmth_asb.F90 +++ b/mlprec/impl/mld_caggrmat_nosmth_asb.F90 @@ -66,7 +66,7 @@ ! the fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of the fine-level matrix. -! p - type(mld_conelev_type), input/output. +! p - type(mld_c_onelev_type), input/output. ! The 'one-level' data structure that will contain the local ! part of the matrix to be built as well as the information ! concerning the prolongator and its transpose. @@ -97,7 +97,7 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_conelev_type), intent(inout), target :: p + type(mld_c_onelev_type), intent(inout), target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_caggrmat_smth_asb.F90 b/mlprec/impl/mld_caggrmat_smth_asb.F90 similarity index 99% rename from mlprec/mld_caggrmat_smth_asb.F90 rename to mlprec/impl/mld_caggrmat_smth_asb.F90 index a2b6b235..d51a0886 100644 --- a/mlprec/mld_caggrmat_smth_asb.F90 +++ b/mlprec/impl/mld_caggrmat_smth_asb.F90 @@ -83,7 +83,7 @@ ! the fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of the fine-level matrix. -! p - type(mld_conelev_type), input/output. +! p - type(mld_c_onelev_type), input/output. ! The 'one-level' data structure that will contain the local ! part of the matrix to be built as well as the information ! concerning the prolongator and its transpose. @@ -114,7 +114,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_conelev_type), intent(inout), target :: p + type(mld_c_onelev_type), intent(inout), target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_ccoarse_bld.f90 b/mlprec/impl/mld_ccoarse_bld.f90 similarity index 98% rename from mlprec/mld_ccoarse_bld.f90 rename to mlprec/impl/mld_ccoarse_bld.f90 index 595732c6..69fa127e 100644 --- a/mlprec/mld_ccoarse_bld.f90 +++ b/mlprec/impl/mld_ccoarse_bld.f90 @@ -58,7 +58,7 @@ ! fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of a. -! p - type(mld_conelev_type), input/output. +! p - type(mld_c_onelev_type), input/output. ! The 'one-level' data structure containing the local part ! of the base preconditioner to be built as well as ! information concerning the prolongator and its transpose. @@ -75,7 +75,7 @@ subroutine mld_ccoarse_bld(a,desc_a,p,info) ! Arguments type(psb_cspmat_type), intent(in), target :: a type(psb_desc_type), intent(in), target :: desc_a - type(mld_conelev_type), intent(inout),target :: p + type(mld_c_onelev_type), intent(inout),target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_cilu0_fact.f90 b/mlprec/impl/mld_cilu0_fact.f90 similarity index 100% rename from mlprec/mld_cilu0_fact.f90 rename to mlprec/impl/mld_cilu0_fact.f90 diff --git a/mlprec/mld_ciluk_fact.f90 b/mlprec/impl/mld_ciluk_fact.f90 similarity index 100% rename from mlprec/mld_ciluk_fact.f90 rename to mlprec/impl/mld_ciluk_fact.f90 diff --git a/mlprec/mld_cilut_fact.f90 b/mlprec/impl/mld_cilut_fact.f90 similarity index 100% rename from mlprec/mld_cilut_fact.f90 rename to mlprec/impl/mld_cilut_fact.f90 diff --git a/mlprec/mld_cmlprec_aply.f90 b/mlprec/impl/mld_cmlprec_aply.f90 similarity index 100% rename from mlprec/mld_cmlprec_aply.f90 rename to mlprec/impl/mld_cmlprec_aply.f90 diff --git a/mlprec/mld_cmlprec_bld.f90 b/mlprec/impl/mld_cmlprec_bld.f90 similarity index 99% rename from mlprec/mld_cmlprec_bld.f90 rename to mlprec/impl/mld_cmlprec_bld.f90 index 6164ee9b..6ccadf6d 100644 --- a/mlprec/mld_cmlprec_bld.f90 +++ b/mlprec/impl/mld_cmlprec_bld.f90 @@ -353,7 +353,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) contains subroutine check_coarse_lev(prec) - type(mld_conelev_type) :: prec + type(mld_c_onelev_type) :: prec ! ! At the coarsest level, check mld_coarse_solve_ diff --git a/mlprec/mld_cprecaply.f90 b/mlprec/impl/mld_cprecaply.f90 similarity index 100% rename from mlprec/mld_cprecaply.f90 rename to mlprec/impl/mld_cprecaply.f90 diff --git a/mlprec/mld_cprecbld.f90 b/mlprec/impl/mld_cprecbld.f90 similarity index 100% rename from mlprec/mld_cprecbld.f90 rename to mlprec/impl/mld_cprecbld.f90 diff --git a/mlprec/mld_cprecinit.F90 b/mlprec/impl/mld_cprecinit.F90 similarity index 100% rename from mlprec/mld_cprecinit.F90 rename to mlprec/impl/mld_cprecinit.F90 diff --git a/mlprec/mld_cprecset.F90 b/mlprec/impl/mld_cprecset.F90 similarity index 99% rename from mlprec/mld_cprecset.F90 rename to mlprec/impl/mld_cprecset.F90 index 4cec2e34..167f6bc4 100644 --- a/mlprec/mld_cprecset.F90 +++ b/mlprec/impl/mld_cprecset.F90 @@ -341,7 +341,7 @@ subroutine mld_cprecseti(p,what,val,info,ilev) contains subroutine onelev_set_smoother(level,val,info) - type(mld_conelev_type), intent(inout) :: level + type(mld_c_onelev_type), intent(inout) :: level integer, intent(in) :: val integer, intent(out) :: info info = psb_success_ @@ -438,7 +438,7 @@ contains end subroutine onelev_set_smoother subroutine onelev_set_solver(level,val,info) - type(mld_conelev_type), intent(inout) :: level + type(mld_c_onelev_type), intent(inout) :: level integer, intent(in) :: val integer, intent(out) :: info info = psb_success_ diff --git a/mlprec/mld_cslu_bld.f90 b/mlprec/impl/mld_cslu_bld.f90 similarity index 100% rename from mlprec/mld_cslu_bld.f90 rename to mlprec/impl/mld_cslu_bld.f90 diff --git a/mlprec/mld_cslu_interface.c b/mlprec/impl/mld_cslu_interface.c similarity index 100% rename from mlprec/mld_cslu_interface.c rename to mlprec/impl/mld_cslu_interface.c diff --git a/mlprec/mld_cslud_bld.f90 b/mlprec/impl/mld_cslud_bld.f90 similarity index 100% rename from mlprec/mld_cslud_bld.f90 rename to mlprec/impl/mld_cslud_bld.f90 diff --git a/mlprec/mld_cslud_interface.c b/mlprec/impl/mld_cslud_interface.c similarity index 100% rename from mlprec/mld_cslud_interface.c rename to mlprec/impl/mld_cslud_interface.c diff --git a/mlprec/mld_csp_renum.f90 b/mlprec/impl/mld_csp_renum.f90 similarity index 100% rename from mlprec/mld_csp_renum.f90 rename to mlprec/impl/mld_csp_renum.f90 diff --git a/mlprec/mld_cumf_interface.c b/mlprec/impl/mld_cumf_interface.c similarity index 100% rename from mlprec/mld_cumf_interface.c rename to mlprec/impl/mld_cumf_interface.c diff --git a/mlprec/impl/mld_d_as_smoother_impl.f90 b/mlprec/impl/mld_d_as_smoother_impl.f90 new file mode 100644 index 00000000..dfd743c4 --- /dev/null +++ b/mlprec/impl/mld_d_as_smoother_impl.f90 @@ -0,0 +1,1344 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) +!!$ +!!$ (C) Copyright 2008,2009,2010, 2010 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the MLD2P4 group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! +! +! +! +! + +subroutine mld_d_as_smoother_check(sm,info) + + use psb_base_mod + use mld_d_as_smoother, mld_protect_nam => mld_d_as_smoother_check + + Implicit None + + ! Arguments + class(mld_d_as_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_as_smoother_check' + + call psb_erractionsave(err_act) + info = psb_success_ + + call mld_check_def(sm%restr,& + & 'Restrictor',psb_halo_,is_legal_restrict) + call mld_check_def(sm%prol,& + & 'Prolongator',psb_none_,is_legal_prolong) + call mld_check_def(sm%novr,& + & 'Overlap layers ',0,is_legal_n_ovr) + + + if (allocated(sm%sv)) then + call sm%sv%check(info) + else + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + if (info /= psb_success_) goto 9999 + + 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 mld_d_as_smoother_check + +subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + use psb_base_mod + use mld_d_as_smoother, mld_protect_nam => mld_d_as_smoother_apply_vect + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_d_as_smoother_type), intent(inout) :: sm + type(psb_d_vect_type),intent(inout) :: x + type(psb_d_vect_type),intent(inout) :: y + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + integer, intent(in) :: sweeps + real(psb_dpk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + + integer :: n_row,n_col, nrow_d, i + real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_dpk_), allocatable :: vx(:) + type(psb_d_vect_type) :: vtx, vty, vww + integer :: ictxt,np,me, err_act,isz,int_err(5) + character :: trans_ + character(len=20) :: name='d_as_smoother_apply', ch_err + + call psb_erractionsave(err_act) + + info = psb_success_ + ictxt = desc_data%get_context() + call psb_info(ictxt,me,np) + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T') + case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + if (.not.allocated(sm%sv)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + + n_row = sm%desc_data%get_local_rows() + n_col = sm%desc_data%get_local_cols() + nrow_d = desc_data%get_local_rows() + isz = max(n_row,N_COL) + + if ((6*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + aux => work(3*isz+1:) + else if ((4*isz) <= size(work)) then + aux => work(1:) + allocate(ww(isz),tx(isz),ty(isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + else if ((3*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + allocate(aux(4*isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + else + allocate(ww(isz),tx(isz),ty(isz),& + &aux(4*isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + + endif + + if ((sm%novr == 0).and.(sweeps == 1)) then + ! + ! Shortcut: in this case it's just the same + ! as Block Jacobi. + ! + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + else + + + vx = x%get_vect() + + call psb_geall(vtx,sm%desc_data,info) + call psb_geasb(vtx,sm%desc_data,info,mold=x%v) + call psb_geall(vty,sm%desc_data,info) + call psb_geasb(vty,sm%desc_data,info,mold=x%v) + call psb_geall(vww,sm%desc_data,info) + call psb_geasb(vww,sm%desc_data,info,mold=x%v) + call vtx%set(dzero) + call vty%set(dzero) + call vww%set(dzero) + + + call vtx%set(vx(1:nrow_d)) + + if (sweeps == 1) then + + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx == x) + ! + if (sm%restr == psb_halo_) then + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (sm%prol) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(vtx,sm%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + call sm%sv%apply(done,vtx,dzero,vty,sm%desc_data,trans_,aux,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + select case(trans_) + case('N') + + select case (sm%prol) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,sm%desc_data,info,& + ! & update=sm%prol,work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(vty,sm%desc_data,info,& + & update=sm%prol,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + if (sm%restr == psb_halo_) then + call psb_ovrl(vty,sm%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + + + else if (sweeps > 1) then + + ! + ! + ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver + ! to compute an approximate solution of a linear system. + ! + ! + call vty%set(dzero) + + do i=1, sweeps + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx == x) + ! + if (sm%restr == psb_halo_) then + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (sm%prol) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(vtx,sm%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + call psb_geaxpby(done,vtx,dzero,vww,sm%desc_data,info) + call psb_spmm(-done,sm%nd,vty,done,vww,sm%desc_data,info,& + & work=aux,trans=trans_) + + if (info /= psb_success_) exit + + call sm%sv%apply(done,vww,dzero,vty,sm%desc_data,trans_,aux,info) + + if (info /= psb_success_) exit + + + select case(trans_) + case('N') + + select case (sm%prol) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,sm%desc_data,info,& + ! & update=sm%prol,work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(vty,sm%desc_data,info,& + & update=sm%prol,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + if (sm%restr == psb_halo_) then + call psb_ovrl(vty,sm%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + end do + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + + else + + info = psb_err_iarg_neg_ + call psb_errpush(info,name,& + & i_err=(/2,sweeps,0,0,0/)) + goto 9999 + + + end if + + ! + ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) + ! + call psb_geaxpby(alpha,vty,beta,y,desc_data,info) + + end if + + + if ((6*isz) <= size(work)) then + else if ((4*isz) <= size(work)) then + deallocate(ww,tx,ty) + else if ((3*isz) <= size(work)) then + deallocate(aux) + else + deallocate(ww,aux,tx,ty) + endif + call vww%free(info) + call vtx%free(info) + call vty%free(info) + + 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 mld_d_as_smoother_apply_vect + + +subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + use psb_base_mod + use mld_d_as_smoother, mld_protect_nam => mld_d_as_smoother_apply + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_d_as_smoother_type), intent(in) :: sm + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(inout) :: y(:) + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + integer, intent(in) :: sweeps + real(psb_dpk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + + integer :: n_row,n_col, nrow_d, i + real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me, err_act,isz,int_err(5) + character :: trans_ + character(len=20) :: name='d_as_smoother_apply', ch_err + + call psb_erractionsave(err_act) + + info = psb_success_ + ictxt = desc_data%get_context() + call psb_info (ictxt,me,np) + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T') + case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + if (.not.allocated(sm%sv)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + + n_row = sm%desc_data%get_local_rows() + n_col = sm%desc_data%get_local_cols() + nrow_d = desc_data%get_local_rows() + isz=max(n_row,N_COL) + if ((6*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + aux => work(3*isz+1:) + else if ((4*isz) <= size(work)) then + aux => work(1:) + allocate(ww(isz),tx(isz),ty(isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + else if ((3*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + allocate(aux(4*isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + else + allocate(ww(isz),tx(isz),ty(isz),& + &aux(4*isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + + endif + + if ((sm%novr == 0).and.(sweeps == 1)) then + ! + ! Shortcut: in this case it's just the same + ! as Block Jacobi. + ! + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + else + + + tx(1:nrow_d) = x(1:nrow_d) + tx(nrow_d+1:isz) = dzero + + + if (sweeps == 1) then + + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx == x) + ! + if (sm%restr == psb_halo_) then + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (sm%prol) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(tx,sm%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + call sm%sv%apply(done,tx,dzero,ty,sm%desc_data,trans_,aux,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + select case(trans_) + case('N') + + select case (sm%prol) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,sm%desc_data,info,& + ! & update=sm%prol,work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(ty,sm%desc_data,info,& + & update=sm%prol,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + if (sm%restr == psb_halo_) then + call psb_ovrl(ty,sm%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + + + else if (sweeps > 1) then + + ! + ! + ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver + ! to compute an approximate solution of a linear system. + ! + ! + ty = dzero + do i=1, sweeps + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx == x) + ! + if (sm%restr == psb_halo_) then + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (sm%prol) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(tx,sm%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + ww(1:n_row) = tx(1:n_row) + call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,work=aux,trans=trans_) + + if (info /= psb_success_) exit + + call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info) + + if (info /= psb_success_) exit + + + select case(trans_) + case('N') + + select case (sm%prol) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,sm%desc_data,info,& + ! & update=sm%prol,work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(ty,sm%desc_data,info,& + & update=sm%prol,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + if (sm%restr == psb_halo_) then + call psb_ovrl(ty,sm%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + end do + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + + else + + info = psb_err_iarg_neg_ + call psb_errpush(info,name,& + & i_err=(/2,sweeps,0,0,0/)) + goto 9999 + + + end if + + ! + ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) + ! + call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + + end if + + + if ((6*isz) <= size(work)) then + else if ((4*isz) <= size(work)) then + deallocate(ww,tx,ty) + else if ((3*isz) <= size(work)) then + deallocate(aux) + else + deallocate(ww,aux,tx,ty) + endif + + 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 mld_d_as_smoother_apply + +subroutine mld_d_as_smoother_bld(a,desc_a,sm,upd,info,amold,vmold) + use psb_base_mod + use mld_d_as_smoother, mld_protect_nam => mld_d_as_smoother_bld + Implicit None + + ! Arguments + type(psb_dspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_d_as_smoother_type), intent(inout) :: sm + character, intent(in) :: upd + integer, intent(out) :: info + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + + ! Local variables + type(psb_dspmat_type) :: blck, atmp + integer :: n_row,n_col, nrow_a, nhalo, novr, data_, nzeros + real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='d_as_smoother_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + novr = sm%novr + if (novr < 0) then + info=psb_err_invalid_ovr_num_ + call psb_errpush(info,name,i_err=(/novr,0,0,0,0,0/)) + goto 9999 + endif + + if ((novr == 0).or.(np == 1)) then + if (psb_toupper(upd) == 'F') then + call psb_cdcpy(desc_a,sm%desc_data,info) + If(debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' done cdcpy' + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Early return: P>=3 N_OVR=0' + endif + call blck%csall(0,0,info,1) + else + + If (psb_toupper(upd) == 'F') Then + ! + ! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_). + ! This is done by psb_cdbldext (interface to psb_cdovr), which is + ! independent of CSR, and has been placed in the tools directory + ! of PSBLAS, instead of the mlprec directory of MLD2P4, because it + ! might be used independently of the AS preconditioner, to build + ! a descriptor for an extended stencil in a PDE solver. + ! + call psb_cdbldext(a,desc_a,novr,sm%desc_data,info,extype=psb_ovt_asov_) + if(debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' From cdbldext _:',sm%desc_data%get_local_rows(),& + & sm%desc_data%get_local_cols() + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_cdbldext' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + Endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Before sphalo ' + + ! + ! Retrieve the remote sparse matrix rows required for the AS extended + ! matrix + data_ = psb_comm_ext_ + Call psb_sphalo(a,sm%desc_data,blck,info,data=data_,rowscale=.true.) + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sphalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (debug_level >=psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'After psb_sphalo ',& + & blck%get_nrows(), blck%get_nzeros() + + End if + if (info == psb_success_) & + & call sm%sv%build(a,sm%desc_data,upd,info,& + & blck,amold=amold,vmold=vmold) + + nrow_a = a%get_nrows() + n_row = sm%desc_data%get_local_rows() + n_col = sm%desc_data%get_local_cols() + + if (info == psb_success_) call a%csclip(sm%nd,info,& + & jmin=nrow_a+1,rscale=.false.,cscale=.false.) + if (info == psb_success_) call blck%csclip(atmp,info,& + & jmin=nrow_a+1,rscale=.false.,cscale=.false.) + if (info == psb_success_) call psb_rwextd(n_row,sm%nd,info,b=atmp) + + if (info == psb_success_) then + if (present(amold)) then + call sm%nd%cscnv(info,& + & mold=amold,dupl=psb_dupl_add_) + else + call sm%nd%cscnv(info,& + & type='csr',dupl=psb_dupl_add_) + end if + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4') + goto 9999 + end if + nzeros = sm%nd%get_nzeros() +!!$ write(0,*) me,' ND nzeors ',nzeros + call psb_sum(ictxt,nzeros) + sm%nd_nnz_tot = nzeros + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + 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 mld_d_as_smoother_bld + + +subroutine mld_d_as_smoother_seti(sm,what,val,info) + use psb_base_mod + use mld_d_as_smoother, mld_protect_nam => mld_d_as_smoother_seti + Implicit None + + ! Arguments + class(mld_d_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_as_smoother_seti' + + info = psb_success_ + 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_) + sm%restr = val + case(mld_sub_prol_) + sm%prol = 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 mld_d_as_smoother_seti + +subroutine mld_d_as_smoother_setc(sm,what,val,info) + use psb_base_mod + use mld_d_as_smoother, mld_protect_nam => mld_d_as_smoother_setc + Implicit None + ! Arguments + class(mld_d_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + character(len=*), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, ival + character(len=20) :: name='d_as_smoother_setc' + + info = psb_success_ + call psb_erractionsave(err_act) + + + call mld_stringval(val,ival,info) + if (info == psb_success_) call sm%set(what,ival,info) + 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 mld_d_as_smoother_setc + +subroutine mld_d_as_smoother_setr(sm,what,val,info) + use psb_base_mod + use mld_d_as_smoother, mld_protect_nam => mld_d_as_smoother_setr + Implicit None + ! Arguments + class(mld_d_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_as_smoother_setr' + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (allocated(sm%sv)) then + call sm%sv%set(what,val,info) + else +!!$ write(0,*) trim(name),' Missing component, not setting!' +!!$ info = 1121 + 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 mld_d_as_smoother_setr + +subroutine mld_d_as_smoother_free(sm,info) + use psb_base_mod + use mld_d_as_smoother, mld_protect_nam => mld_d_as_smoother_free + Implicit None + ! Arguments + class(mld_d_as_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_as_smoother_free' + + call psb_erractionsave(err_act) + info = psb_success_ + + + + if (allocated(sm%sv)) then + call sm%sv%free(info) + if (info == psb_success_) deallocate(sm%sv,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + end if + call sm%nd%free() + + 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 mld_d_as_smoother_free + +subroutine mld_d_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) + use psb_base_mod + use mld_d_as_smoother, mld_protect_nam => mld_d_as_smoother_dmp + implicit none + class(mld_d_as_smoother_type), intent(in) :: sm + integer, intent(in) :: ictxt,level + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: smoother, solver + integer :: i, j, il1, iln, lname, lev + integer :: icontxt,iam, np + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + logical :: smoother_ + ! len of prefix_ + + info = 0 + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_smth_d" + end if + + call psb_info(ictxt,iam,np) + + if (present(smoother)) then + smoother_ = smoother + else + smoother_ = .false. + end if + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + + if (smoother_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx' + if (sm%nd%is_asb()) & + & call sm%nd%print(fname,head=head) + end if + ! At base level do nothing for the smoother + if (allocated(sm%sv)) & + & call sm%sv%dump(ictxt,level,info,solver=solver) + +end subroutine mld_d_as_smoother_dmp + diff --git a/mlprec/mld_d_base_smoother_impl.f90 b/mlprec/impl/mld_d_base_smoother_impl.f90 similarity index 99% rename from mlprec/mld_d_base_smoother_impl.f90 rename to mlprec/impl/mld_d_base_smoother_impl.f90 index 1ff979f1..ea293a6a 100644 --- a/mlprec/mld_d_base_smoother_impl.f90 +++ b/mlprec/impl/mld_d_base_smoother_impl.f90 @@ -341,7 +341,7 @@ end subroutine mld_d_base_smoother_bld ! subroutine mld_d_base_smoother_free(sm,info) use psb_base_mod - use mld_d_base_smoother_mod, mld_protect_name => s + use mld_d_base_smoother_mod, mld_protect_name => mld_d_base_smoother_free Implicit None ! Arguments diff --git a/mlprec/mld_d_base_solver_impl.f90 b/mlprec/impl/mld_d_base_solver_impl.f90 similarity index 100% rename from mlprec/mld_d_base_solver_impl.f90 rename to mlprec/impl/mld_d_base_solver_impl.f90 diff --git a/mlprec/mld_d_dec_map_bld.F90 b/mlprec/impl/mld_d_dec_map_bld.F90 similarity index 100% rename from mlprec/mld_d_dec_map_bld.F90 rename to mlprec/impl/mld_d_dec_map_bld.F90 diff --git a/mlprec/mld_d_onelev_impl.f90 b/mlprec/impl/mld_d_onelev_impl.f90 similarity index 93% rename from mlprec/mld_d_onelev_impl.f90 rename to mlprec/impl/mld_d_onelev_impl.f90 index 762f9406..976545f1 100644 --- a/mlprec/mld_d_onelev_impl.f90 +++ b/mlprec/impl/mld_d_onelev_impl.f90 @@ -57,10 +57,10 @@ ! subroutine mld_d_base_onelev_descr(lv,il,nl,info,iout) use psb_base_mod - use mld_donelev_mod, mld_protect_name => mld_d_base_onelev_descr + use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_descr Implicit None ! Arguments - class(mld_donelev_type), intent(in) :: lv + class(mld_d_onelev_type), intent(in) :: lv integer, intent(in) :: il,nl integer, intent(out) :: info integer, intent(in), optional :: iout @@ -137,10 +137,10 @@ end subroutine mld_d_base_onelev_descr ! subroutine mld_d_base_onelev_free(lv,info) use psb_base_mod - use mld_donelev_mod, mld_protect_name =>: mld_T_onelev_precfree + use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_free implicit none - class(mld_donelev_type), intent(inout) :: lv + class(mld_d_onelev_type), intent(inout) :: lv integer, intent(out) :: info integer :: i @@ -175,12 +175,12 @@ end subroutine mld_d_base_onelev_free ! subroutine mld_d_base_onelev_check(lv,info) use psb_base_mod - use mld_donelev_mod, mld_protect_name => mld_d_base_onelev_check + use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_check Implicit None ! Arguments - class(mld_donelev_type), intent(inout) :: lv + class(mld_d_onelev_type), intent(inout) :: lv integer, intent(out) :: info Integer :: err_act character(len=20) :: name='d_base_onelev_check' @@ -231,12 +231,12 @@ end subroutine mld_d_base_onelev_check ! subroutine mld_d_base_onelev_seti(lv,what,val,info) use psb_base_mod - use mld_donelev_mod, mld_protect_name => mld_d_base_onelev_seti + use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_seti Implicit None ! Arguments - class(mld_donelev_type), intent(inout) :: lv + class(mld_d_onelev_type), intent(inout) :: lv integer, intent(in) :: what integer, intent(in) :: val integer, intent(out) :: info @@ -306,12 +306,12 @@ end subroutine mld_d_base_onelev_seti subroutine mld_d_base_onelev_setc(lv,what,val,info) use psb_base_mod - use mld_donelev_mod, mld_protect_name => mld_d_base_onelev_setc + use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_setc Implicit None ! Arguments - class(mld_donelev_type), intent(inout) :: lv + class(mld_d_onelev_type), intent(inout) :: lv integer, intent(in) :: what character(len=*), intent(in) :: val integer, intent(out) :: info @@ -342,12 +342,12 @@ end subroutine mld_d_base_onelev_setc subroutine mld_d_base_onelev_setr(lv,what,val,info) use psb_base_mod - use mld_donelev_mod, mld_protect_name => mld_d_base_onelev_setr + use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_setr Implicit None ! Arguments - class(mld_donelev_type), intent(inout) :: lv + class(mld_d_onelev_type), intent(inout) :: lv integer, intent(in) :: what real(psb_dpk_), intent(in) :: val integer, intent(out) :: info @@ -392,9 +392,9 @@ end subroutine mld_d_base_onelev_setr ! subroutine mld_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver) use psb_base_mod - use mld_donelev_mod, mld_protect_name => mld_d_base_onelev_dump + use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_dump implicit none - class(mld_donelev_type), intent(in) :: lv + class(mld_d_onelev_type), intent(in) :: lv integer, intent(in) :: level integer, intent(out) :: info character(len=*), intent(in), optional :: prefix, head diff --git a/mlprec/mld_daggrmap_bld.f90 b/mlprec/impl/mld_daggrmap_bld.f90 similarity index 100% rename from mlprec/mld_daggrmap_bld.f90 rename to mlprec/impl/mld_daggrmap_bld.f90 diff --git a/mlprec/mld_daggrmat_asb.f90 b/mlprec/impl/mld_daggrmat_asb.f90 similarity index 98% rename from mlprec/mld_daggrmat_asb.f90 rename to mlprec/impl/mld_daggrmat_asb.f90 index 98810bf9..03208ac1 100644 --- a/mlprec/mld_daggrmat_asb.f90 +++ b/mlprec/impl/mld_daggrmat_asb.f90 @@ -83,7 +83,7 @@ ! the fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of the fine-level matrix. -! p - type(mld_donelev_type), input/output. +! p - type(mld_d_onelev_type), input/output. ! The 'one-level' data structure that will contain the local ! part of the matrix to be built as well as the information ! concerning the prolongator and its transpose. @@ -109,7 +109,7 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_donelev_type), intent(inout), target :: p + type(mld_d_onelev_type), intent(inout), target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_daggrmat_minnrg_asb.F90 b/mlprec/impl/mld_daggrmat_minnrg_asb.F90 similarity index 99% rename from mlprec/mld_daggrmat_minnrg_asb.F90 rename to mlprec/impl/mld_daggrmat_minnrg_asb.F90 index 4951948a..af068f9c 100644 --- a/mlprec/mld_daggrmat_minnrg_asb.F90 +++ b/mlprec/impl/mld_daggrmat_minnrg_asb.F90 @@ -83,7 +83,7 @@ ! the fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of the fine-level matrix. -! p - type(mld_donelev_type), input/output. +! p - type(mld_d_onelev_type), input/output. ! The 'one-level' data structure that will contain the local ! part of the matrix to be built as well as the information ! concerning the prolongator and its transpose. @@ -114,7 +114,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_donelev_type), intent(inout), target :: p + type(mld_d_onelev_type), intent(inout), target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_daggrmat_nosmth_asb.F90 b/mlprec/impl/mld_daggrmat_nosmth_asb.F90 similarity index 98% rename from mlprec/mld_daggrmat_nosmth_asb.F90 rename to mlprec/impl/mld_daggrmat_nosmth_asb.F90 index f8eaf50c..9a9c4e3a 100644 --- a/mlprec/mld_daggrmat_nosmth_asb.F90 +++ b/mlprec/impl/mld_daggrmat_nosmth_asb.F90 @@ -66,7 +66,7 @@ ! the fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of the fine-level matrix. -! p - type(mld_donelev_type), input/output. +! p - type(mld_d_onelev_type), input/output. ! The 'one-level' data structure that will contain the local ! part of the matrix to be built as well as the information ! concerning the prolongator and its transpose. @@ -97,7 +97,7 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_donelev_type), intent(inout), target :: p + type(mld_d_onelev_type), intent(inout), target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_daggrmat_smth_asb.F90 b/mlprec/impl/mld_daggrmat_smth_asb.F90 similarity index 99% rename from mlprec/mld_daggrmat_smth_asb.F90 rename to mlprec/impl/mld_daggrmat_smth_asb.F90 index 55ac8301..cf905100 100644 --- a/mlprec/mld_daggrmat_smth_asb.F90 +++ b/mlprec/impl/mld_daggrmat_smth_asb.F90 @@ -83,7 +83,7 @@ ! the fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of the fine-level matrix. -! p - type(mld_donelev_type), input/output. +! p - type(mld_d_onelev_type), input/output. ! The 'one-level' data structure that will contain the local ! part of the matrix to be built as well as the information ! concerning the prolongator and its transpose. @@ -114,7 +114,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_donelev_type), intent(inout), target :: p + type(mld_d_onelev_type), intent(inout), target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_dcoarse_bld.f90 b/mlprec/impl/mld_dcoarse_bld.f90 similarity index 98% rename from mlprec/mld_dcoarse_bld.f90 rename to mlprec/impl/mld_dcoarse_bld.f90 index 51cad86b..fbc64e16 100644 --- a/mlprec/mld_dcoarse_bld.f90 +++ b/mlprec/impl/mld_dcoarse_bld.f90 @@ -58,7 +58,7 @@ ! fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of a. -! p - type(mld_donelev_type), input/output. +! p - type(mld_d_onelev_type), input/output. ! The 'one-level' data structure containing the local part ! of the base preconditioner to be built as well as ! information concerning the prolongator and its transpose. @@ -75,7 +75,7 @@ subroutine mld_dcoarse_bld(a,desc_a,p,info) ! Arguments type(psb_dspmat_type), intent(in), target :: a type(psb_desc_type), intent(in), target :: desc_a - type(mld_donelev_type), intent(inout),target :: p + type(mld_d_onelev_type), intent(inout),target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_dilu0_fact.f90 b/mlprec/impl/mld_dilu0_fact.f90 similarity index 100% rename from mlprec/mld_dilu0_fact.f90 rename to mlprec/impl/mld_dilu0_fact.f90 diff --git a/mlprec/mld_diluk_fact.f90 b/mlprec/impl/mld_diluk_fact.f90 similarity index 100% rename from mlprec/mld_diluk_fact.f90 rename to mlprec/impl/mld_diluk_fact.f90 diff --git a/mlprec/mld_dilut_fact.f90 b/mlprec/impl/mld_dilut_fact.f90 similarity index 100% rename from mlprec/mld_dilut_fact.f90 rename to mlprec/impl/mld_dilut_fact.f90 diff --git a/mlprec/mld_dmlprec_aply.f90 b/mlprec/impl/mld_dmlprec_aply.f90 similarity index 100% rename from mlprec/mld_dmlprec_aply.f90 rename to mlprec/impl/mld_dmlprec_aply.f90 diff --git a/mlprec/mld_dmlprec_bld.f90 b/mlprec/impl/mld_dmlprec_bld.f90 similarity index 99% rename from mlprec/mld_dmlprec_bld.f90 rename to mlprec/impl/mld_dmlprec_bld.f90 index c3169a89..18189e4b 100644 --- a/mlprec/mld_dmlprec_bld.f90 +++ b/mlprec/impl/mld_dmlprec_bld.f90 @@ -353,7 +353,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) contains subroutine check_coarse_lev(prec) - type(mld_donelev_type) :: prec + type(mld_d_onelev_type) :: prec ! ! At the coarsest level, check mld_coarse_solve_ diff --git a/mlprec/mld_dprecaply.f90 b/mlprec/impl/mld_dprecaply.f90 similarity index 100% rename from mlprec/mld_dprecaply.f90 rename to mlprec/impl/mld_dprecaply.f90 diff --git a/mlprec/mld_dprecbld.f90 b/mlprec/impl/mld_dprecbld.f90 similarity index 100% rename from mlprec/mld_dprecbld.f90 rename to mlprec/impl/mld_dprecbld.f90 diff --git a/mlprec/mld_dprecinit.F90 b/mlprec/impl/mld_dprecinit.F90 similarity index 100% rename from mlprec/mld_dprecinit.F90 rename to mlprec/impl/mld_dprecinit.F90 diff --git a/mlprec/mld_dprecset.F90 b/mlprec/impl/mld_dprecset.F90 similarity index 99% rename from mlprec/mld_dprecset.F90 rename to mlprec/impl/mld_dprecset.F90 index 48cb8796..28a649fb 100644 --- a/mlprec/mld_dprecset.F90 +++ b/mlprec/impl/mld_dprecset.F90 @@ -341,7 +341,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev) contains subroutine onelev_set_smoother(level,val,info) - type(mld_donelev_type), intent(inout) :: level + type(mld_d_onelev_type), intent(inout) :: level integer, intent(in) :: val integer, intent(out) :: info info = psb_success_ @@ -438,7 +438,7 @@ contains end subroutine onelev_set_smoother subroutine onelev_set_solver(level,val,info) - type(mld_donelev_type), intent(inout) :: level + type(mld_d_onelev_type), intent(inout) :: level integer, intent(in) :: val integer, intent(out) :: info info = psb_success_ diff --git a/mlprec/mld_dslu_bld.f90 b/mlprec/impl/mld_dslu_bld.f90 similarity index 100% rename from mlprec/mld_dslu_bld.f90 rename to mlprec/impl/mld_dslu_bld.f90 diff --git a/mlprec/mld_dslu_interface.c b/mlprec/impl/mld_dslu_interface.c similarity index 100% rename from mlprec/mld_dslu_interface.c rename to mlprec/impl/mld_dslu_interface.c diff --git a/mlprec/mld_dslud_bld.f90 b/mlprec/impl/mld_dslud_bld.f90 similarity index 100% rename from mlprec/mld_dslud_bld.f90 rename to mlprec/impl/mld_dslud_bld.f90 diff --git a/mlprec/mld_dslud_interface.c b/mlprec/impl/mld_dslud_interface.c similarity index 100% rename from mlprec/mld_dslud_interface.c rename to mlprec/impl/mld_dslud_interface.c diff --git a/mlprec/mld_dsp_renum.f90 b/mlprec/impl/mld_dsp_renum.f90 similarity index 100% rename from mlprec/mld_dsp_renum.f90 rename to mlprec/impl/mld_dsp_renum.f90 diff --git a/mlprec/mld_dumf_interface.c b/mlprec/impl/mld_dumf_interface.c similarity index 100% rename from mlprec/mld_dumf_interface.c rename to mlprec/impl/mld_dumf_interface.c diff --git a/mlprec/impl/mld_s_as_smoother_impl.f90 b/mlprec/impl/mld_s_as_smoother_impl.f90 new file mode 100644 index 00000000..3e0e8e34 --- /dev/null +++ b/mlprec/impl/mld_s_as_smoother_impl.f90 @@ -0,0 +1,1344 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) +!!$ +!!$ (C) Copyright 2008,2009,2010, 2010 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the MLD2P4 group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! +! +! +! +! + +subroutine mld_s_as_smoother_check(sm,info) + + use psb_base_mod + use mld_s_as_smoother, mld_protect_nam => mld_s_as_smoother_check + + Implicit None + + ! Arguments + class(mld_s_as_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='s_as_smoother_check' + + call psb_erractionsave(err_act) + info = psb_success_ + + call mld_check_def(sm%restr,& + & 'Restrictor',psb_halo_,is_legal_restrict) + call mld_check_def(sm%prol,& + & 'Prolongator',psb_none_,is_legal_prolong) + call mld_check_def(sm%novr,& + & 'Overlap layers ',0,is_legal_n_ovr) + + + if (allocated(sm%sv)) then + call sm%sv%check(info) + else + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + if (info /= psb_success_) goto 9999 + + 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 mld_s_as_smoother_check + +subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + use psb_base_mod + use mld_s_as_smoother, mld_protect_nam => mld_s_as_smoother_apply_vect + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_as_smoother_type), intent(inout) :: sm + type(psb_s_vect_type),intent(inout) :: x + type(psb_s_vect_type),intent(inout) :: y + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + integer, intent(in) :: sweeps + real(psb_spk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + + integer :: n_row,n_col, nrow_d, i + real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_spk_), allocatable :: vx(:) + type(psb_s_vect_type) :: vtx, vty, vww + integer :: ictxt,np,me, err_act,isz,int_err(5) + character :: trans_ + character(len=20) :: name='s_as_smoother_apply', ch_err + + call psb_erractionsave(err_act) + + info = psb_success_ + ictxt = desc_data%get_context() + call psb_info(ictxt,me,np) + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T') + case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + if (.not.allocated(sm%sv)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + + n_row = sm%desc_data%get_local_rows() + n_col = sm%desc_data%get_local_cols() + nrow_d = desc_data%get_local_rows() + isz = max(n_row,N_COL) + + if ((6*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + aux => work(3*isz+1:) + else if ((4*isz) <= size(work)) then + aux => work(1:) + allocate(ww(isz),tx(isz),ty(isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + else if ((3*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + allocate(aux(4*isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + else + allocate(ww(isz),tx(isz),ty(isz),& + &aux(4*isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + endif + + if ((sm%novr == 0).and.(sweeps == 1)) then + ! + ! Shortcut: in this case it's just the same + ! as Block Jacobi. + ! + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + else + + + vx = x%get_vect() + + call psb_geall(vtx,sm%desc_data,info) + call psb_geasb(vtx,sm%desc_data,info,mold=x%v) + call psb_geall(vty,sm%desc_data,info) + call psb_geasb(vty,sm%desc_data,info,mold=x%v) + call psb_geall(vww,sm%desc_data,info) + call psb_geasb(vww,sm%desc_data,info,mold=x%v) + call vtx%set(szero) + call vty%set(szero) + call vww%set(szero) + + + call vtx%set(vx(1:nrow_d)) + + if (sweeps == 1) then + + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx == x) + ! + if (sm%restr == psb_halo_) then + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (sm%prol) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(vtx,sm%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + call sm%sv%apply(sone,vtx,szero,vty,sm%desc_data,trans_,aux,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + select case(trans_) + case('N') + + select case (sm%prol) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,sm%desc_data,info,& + ! & update=sm%prol,work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(vty,sm%desc_data,info,& + & update=sm%prol,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + if (sm%restr == psb_halo_) then + call psb_ovrl(vty,sm%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + + + else if (sweeps > 1) then + + ! + ! + ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver + ! to compute an approximate solution of a linear system. + ! + ! + call vty%set(szero) + + do i=1, sweeps + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx == x) + ! + if (sm%restr == psb_halo_) then + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (sm%prol) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(vtx,sm%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + call psb_geaxpby(sone,vtx,szero,vww,sm%desc_data,info) + call psb_spmm(-sone,sm%nd,vty,sone,vww,sm%desc_data,info,& + & work=aux,trans=trans_) + + if (info /= psb_success_) exit + + call sm%sv%apply(sone,vww,szero,vty,sm%desc_data,trans_,aux,info) + + if (info /= psb_success_) exit + + + select case(trans_) + case('N') + + select case (sm%prol) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,sm%desc_data,info,& + ! & update=sm%prol,work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(vty,sm%desc_data,info,& + & update=sm%prol,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + if (sm%restr == psb_halo_) then + call psb_ovrl(vty,sm%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + end do + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + + else + + info = psb_err_iarg_neg_ + call psb_errpush(info,name,& + & i_err=(/2,sweeps,0,0,0/)) + goto 9999 + + + end if + + ! + ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) + ! + call psb_geaxpby(alpha,vty,beta,y,desc_data,info) + + end if + + + if ((6*isz) <= size(work)) then + else if ((4*isz) <= size(work)) then + deallocate(ww,tx,ty) + else if ((3*isz) <= size(work)) then + deallocate(aux) + else + deallocate(ww,aux,tx,ty) + endif + call vww%free(info) + call vtx%free(info) + call vty%free(info) + + 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 mld_s_as_smoother_apply_vect + + +subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + use psb_base_mod + use mld_s_as_smoother, mld_protect_nam => mld_s_as_smoother_apply + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_as_smoother_type), intent(in) :: sm + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + integer, intent(in) :: sweeps + real(psb_spk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + + integer :: n_row,n_col, nrow_d, i + real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me, err_act,isz,int_err(5) + character :: trans_ + character(len=20) :: name='s_as_smoother_apply', ch_err + + call psb_erractionsave(err_act) + + info = psb_success_ + ictxt = desc_data%get_context() + call psb_info (ictxt,me,np) + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T') + case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + if (.not.allocated(sm%sv)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + + n_row = sm%desc_data%get_local_rows() + n_col = sm%desc_data%get_local_cols() + nrow_d = desc_data%get_local_rows() + isz=max(n_row,N_COL) + if ((6*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + aux => work(3*isz+1:) + else if ((4*isz) <= size(work)) then + aux => work(1:) + allocate(ww(isz),tx(isz),ty(isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + else if ((3*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + allocate(aux(4*isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + else + allocate(ww(isz),tx(isz),ty(isz),& + &aux(4*isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + endif + + if ((sm%novr == 0).and.(sweeps == 1)) then + ! + ! Shortcut: in this case it's just the same + ! as Block Jacobi. + ! + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + else + + + tx(1:nrow_d) = x(1:nrow_d) + tx(nrow_d+1:isz) = szero + + + if (sweeps == 1) then + + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx == x) + ! + if (sm%restr == psb_halo_) then + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (sm%prol) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(tx,sm%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + call sm%sv%apply(sone,tx,szero,ty,sm%desc_data,trans_,aux,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + select case(trans_) + case('N') + + select case (sm%prol) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,sm%desc_data,info,& + ! & update=sm%prol,work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(ty,sm%desc_data,info,& + & update=sm%prol,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + if (sm%restr == psb_halo_) then + call psb_ovrl(ty,sm%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + + + else if (sweeps > 1) then + + ! + ! + ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver + ! to compute an approximate solution of a linear system. + ! + ! + ty = szero + do i=1, sweeps + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx == x) + ! + if (sm%restr == psb_halo_) then + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (sm%prol) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(tx,sm%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + ww(1:n_row) = tx(1:n_row) + call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,work=aux,trans=trans_) + + if (info /= psb_success_) exit + + call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info) + + if (info /= psb_success_) exit + + + select case(trans_) + case('N') + + select case (sm%prol) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,sm%desc_data,info,& + ! & update=sm%prol,work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(ty,sm%desc_data,info,& + & update=sm%prol,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + if (sm%restr == psb_halo_) then + call psb_ovrl(ty,sm%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + end do + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + + else + + info = psb_err_iarg_neg_ + call psb_errpush(info,name,& + & i_err=(/2,sweeps,0,0,0/)) + goto 9999 + + + end if + + ! + ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) + ! + call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + + end if + + + if ((6*isz) <= size(work)) then + else if ((4*isz) <= size(work)) then + deallocate(ww,tx,ty) + else if ((3*isz) <= size(work)) then + deallocate(aux) + else + deallocate(ww,aux,tx,ty) + endif + + 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 mld_s_as_smoother_apply + +subroutine mld_s_as_smoother_bld(a,desc_a,sm,upd,info,amold,vmold) + use psb_base_mod + use mld_s_as_smoother, mld_protect_nam => mld_s_as_smoother_bld + Implicit None + + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_s_as_smoother_type), intent(inout) :: sm + character, intent(in) :: upd + integer, intent(out) :: info + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + + ! Local variables + type(psb_sspmat_type) :: blck, atmp + integer :: n_row,n_col, nrow_a, nhalo, novr, data_, nzeros + real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='s_as_smoother_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + novr = sm%novr + if (novr < 0) then + info=psb_err_invalid_ovr_num_ + call psb_errpush(info,name,i_err=(/novr,0,0,0,0,0/)) + goto 9999 + endif + + if ((novr == 0).or.(np == 1)) then + if (psb_toupper(upd) == 'F') then + call psb_cdcpy(desc_a,sm%desc_data,info) + If(debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' done cdcpy' + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Early return: P>=3 N_OVR=0' + endif + call blck%csall(0,0,info,1) + else + + If (psb_toupper(upd) == 'F') Then + ! + ! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_). + ! This is done by psb_cdbldext (interface to psb_cdovr), which is + ! independent of CSR, and has been placed in the tools directory + ! of PSBLAS, instead of the mlprec directory of MLD2P4, because it + ! might be used independently of the AS preconditioner, to build + ! a descriptor for an extended stencil in a PDE solver. + ! + call psb_cdbldext(a,desc_a,novr,sm%desc_data,info,extype=psb_ovt_asov_) + if(debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' From cdbldext _:',sm%desc_data%get_local_rows(),& + & sm%desc_data%get_local_cols() + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_cdbldext' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + Endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Before sphalo ' + + ! + ! Retrieve the remote sparse matrix rows required for the AS extended + ! matrix + data_ = psb_comm_ext_ + Call psb_sphalo(a,sm%desc_data,blck,info,data=data_,rowscale=.true.) + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sphalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (debug_level >=psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'After psb_sphalo ',& + & blck%get_nrows(), blck%get_nzeros() + + End if + if (info == psb_success_) & + & call sm%sv%build(a,sm%desc_data,upd,info,& + & blck,amold=amold,vmold=vmold) + + nrow_a = a%get_nrows() + n_row = sm%desc_data%get_local_rows() + n_col = sm%desc_data%get_local_cols() + + if (info == psb_success_) call a%csclip(sm%nd,info,& + & jmin=nrow_a+1,rscale=.false.,cscale=.false.) + if (info == psb_success_) call blck%csclip(atmp,info,& + & jmin=nrow_a+1,rscale=.false.,cscale=.false.) + if (info == psb_success_) call psb_rwextd(n_row,sm%nd,info,b=atmp) + + if (info == psb_success_) then + if (present(amold)) then + call sm%nd%cscnv(info,& + & mold=amold,dupl=psb_dupl_add_) + else + call sm%nd%cscnv(info,& + & type='csr',dupl=psb_dupl_add_) + end if + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4') + goto 9999 + end if + nzeros = sm%nd%get_nzeros() +!!$ write(0,*) me,' ND nzeors ',nzeros + call psb_sum(ictxt,nzeros) + sm%nd_nnz_tot = nzeros + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + 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 mld_s_as_smoother_bld + + +subroutine mld_s_as_smoother_seti(sm,what,val,info) + use psb_base_mod + use mld_s_as_smoother, mld_protect_nam => mld_s_as_smoother_seti + Implicit None + + ! Arguments + class(mld_s_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='s_as_smoother_seti' + + info = psb_success_ + 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_) + sm%restr = val + case(mld_sub_prol_) + sm%prol = 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 mld_s_as_smoother_seti + +subroutine mld_s_as_smoother_setc(sm,what,val,info) + use psb_base_mod + use mld_s_as_smoother, mld_protect_nam => mld_s_as_smoother_setc + Implicit None + ! Arguments + class(mld_s_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + character(len=*), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, ival + character(len=20) :: name='s_as_smoother_setc' + + info = psb_success_ + call psb_erractionsave(err_act) + + + call mld_stringval(val,ival,info) + if (info == psb_success_) call sm%set(what,ival,info) + 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 mld_s_as_smoother_setc + +subroutine mld_s_as_smoother_setr(sm,what,val,info) + use psb_base_mod + use mld_s_as_smoother, mld_protect_nam => mld_s_as_smoother_setr + Implicit None + ! Arguments + class(mld_s_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='s_as_smoother_setr' + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (allocated(sm%sv)) then + call sm%sv%set(what,val,info) + else +!!$ write(0,*) trim(name),' Missing component, not setting!' +!!$ info = 1121 + 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 mld_s_as_smoother_setr + +subroutine mld_s_as_smoother_free(sm,info) + use psb_base_mod + use mld_s_as_smoother, mld_protect_nam => mld_s_as_smoother_free + Implicit None + ! Arguments + class(mld_s_as_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='s_as_smoother_free' + + call psb_erractionsave(err_act) + info = psb_success_ + + + + if (allocated(sm%sv)) then + call sm%sv%free(info) + if (info == psb_success_) deallocate(sm%sv,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + end if + call sm%nd%free() + + 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 mld_s_as_smoother_free + +subroutine mld_s_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) + use psb_base_mod + use mld_s_as_smoother, mld_protect_nam => mld_s_as_smoother_dmp + implicit none + class(mld_s_as_smoother_type), intent(in) :: sm + integer, intent(in) :: ictxt,level + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: smoother, solver + integer :: i, j, il1, iln, lname, lev + integer :: icontxt,iam, np + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + logical :: smoother_ + ! len of prefix_ + + info = 0 + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_smth_s" + end if + + call psb_info(ictxt,iam,np) + + if (present(smoother)) then + smoother_ = smoother + else + smoother_ = .false. + end if + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + + if (smoother_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx' + if (sm%nd%is_asb()) & + & call sm%nd%print(fname,head=head) + end if + ! At base level do nothing for the smoother + if (allocated(sm%sv)) & + & call sm%sv%dump(ictxt,level,info,solver=solver) + +end subroutine mld_s_as_smoother_dmp + diff --git a/mlprec/mld_s_base_smoother_impl.f90 b/mlprec/impl/mld_s_base_smoother_impl.f90 similarity index 99% rename from mlprec/mld_s_base_smoother_impl.f90 rename to mlprec/impl/mld_s_base_smoother_impl.f90 index 6682200f..fad7365c 100644 --- a/mlprec/mld_s_base_smoother_impl.f90 +++ b/mlprec/impl/mld_s_base_smoother_impl.f90 @@ -341,7 +341,7 @@ end subroutine mld_s_base_smoother_bld ! subroutine mld_s_base_smoother_free(sm,info) use psb_base_mod - use mld_s_base_smoother_mod, mld_protect_name => s + use mld_s_base_smoother_mod, mld_protect_name => mld_s_base_smoother_free Implicit None ! Arguments diff --git a/mlprec/mld_s_base_solver_impl.f90 b/mlprec/impl/mld_s_base_solver_impl.f90 similarity index 100% rename from mlprec/mld_s_base_solver_impl.f90 rename to mlprec/impl/mld_s_base_solver_impl.f90 diff --git a/mlprec/mld_s_dec_map_bld.F90 b/mlprec/impl/mld_s_dec_map_bld.F90 similarity index 100% rename from mlprec/mld_s_dec_map_bld.F90 rename to mlprec/impl/mld_s_dec_map_bld.F90 diff --git a/mlprec/mld_s_onelev_impl.f90 b/mlprec/impl/mld_s_onelev_impl.f90 similarity index 93% rename from mlprec/mld_s_onelev_impl.f90 rename to mlprec/impl/mld_s_onelev_impl.f90 index 4e435727..fb7538af 100644 --- a/mlprec/mld_s_onelev_impl.f90 +++ b/mlprec/impl/mld_s_onelev_impl.f90 @@ -57,10 +57,10 @@ ! subroutine mld_s_base_onelev_descr(lv,il,nl,info,iout) use psb_base_mod - use mld_sonelev_mod, mld_protect_name => mld_s_base_onelev_descr + use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_descr Implicit None ! Arguments - class(mld_sonelev_type), intent(in) :: lv + class(mld_s_onelev_type), intent(in) :: lv integer, intent(in) :: il,nl integer, intent(out) :: info integer, intent(in), optional :: iout @@ -137,10 +137,10 @@ end subroutine mld_s_base_onelev_descr ! subroutine mld_s_base_onelev_free(lv,info) use psb_base_mod - use mld_sonelev_mod, mld_protect_name =>: mld_T_onelev_precfree + use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_free implicit none - class(mld_sonelev_type), intent(inout) :: lv + class(mld_s_onelev_type), intent(inout) :: lv integer, intent(out) :: info integer :: i @@ -175,12 +175,12 @@ end subroutine mld_s_base_onelev_free ! subroutine mld_s_base_onelev_check(lv,info) use psb_base_mod - use mld_sonelev_mod, mld_protect_name => mld_s_base_onelev_check + use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_check Implicit None ! Arguments - class(mld_sonelev_type), intent(inout) :: lv + class(mld_s_onelev_type), intent(inout) :: lv integer, intent(out) :: info Integer :: err_act character(len=20) :: name='s_base_onelev_check' @@ -231,12 +231,12 @@ end subroutine mld_s_base_onelev_check ! subroutine mld_s_base_onelev_seti(lv,what,val,info) use psb_base_mod - use mld_sonelev_mod, mld_protect_name => mld_s_base_onelev_seti + use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_seti Implicit None ! Arguments - class(mld_sonelev_type), intent(inout) :: lv + class(mld_s_onelev_type), intent(inout) :: lv integer, intent(in) :: what integer, intent(in) :: val integer, intent(out) :: info @@ -306,12 +306,12 @@ end subroutine mld_s_base_onelev_seti subroutine mld_s_base_onelev_setc(lv,what,val,info) use psb_base_mod - use mld_sonelev_mod, mld_protect_name => mld_s_base_onelev_setc + use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_setc Implicit None ! Arguments - class(mld_sonelev_type), intent(inout) :: lv + class(mld_s_onelev_type), intent(inout) :: lv integer, intent(in) :: what character(len=*), intent(in) :: val integer, intent(out) :: info @@ -342,12 +342,12 @@ end subroutine mld_s_base_onelev_setc subroutine mld_s_base_onelev_setr(lv,what,val,info) use psb_base_mod - use mld_sonelev_mod, mld_protect_name => mld_s_base_onelev_setr + use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_setr Implicit None ! Arguments - class(mld_sonelev_type), intent(inout) :: lv + class(mld_s_onelev_type), intent(inout) :: lv integer, intent(in) :: what real(psb_spk_), intent(in) :: val integer, intent(out) :: info @@ -392,9 +392,9 @@ end subroutine mld_s_base_onelev_setr ! subroutine mld_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver) use psb_base_mod - use mld_sonelev_mod, mld_protect_name => mld_s_base_onelev_dump + use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_dump implicit none - class(mld_sonelev_type), intent(in) :: lv + class(mld_s_onelev_type), intent(in) :: lv integer, intent(in) :: level integer, intent(out) :: info character(len=*), intent(in), optional :: prefix, head diff --git a/mlprec/mld_saggrmap_bld.f90 b/mlprec/impl/mld_saggrmap_bld.f90 similarity index 100% rename from mlprec/mld_saggrmap_bld.f90 rename to mlprec/impl/mld_saggrmap_bld.f90 diff --git a/mlprec/mld_saggrmat_asb.f90 b/mlprec/impl/mld_saggrmat_asb.f90 similarity index 98% rename from mlprec/mld_saggrmat_asb.f90 rename to mlprec/impl/mld_saggrmat_asb.f90 index 6f037827..9045e32f 100644 --- a/mlprec/mld_saggrmat_asb.f90 +++ b/mlprec/impl/mld_saggrmat_asb.f90 @@ -83,7 +83,7 @@ ! the fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of the fine-level matrix. -! p - type(mld_sonelev_type), input/output. +! p - type(mld_s_onelev_type), input/output. ! The 'one-level' data structure that will contain the local ! part of the matrix to be built as well as the information ! concerning the prolongator and its transpose. @@ -109,7 +109,7 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_sonelev_type), intent(inout), target :: p + type(mld_s_onelev_type), intent(inout), target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_saggrmat_minnrg_asb.F90 b/mlprec/impl/mld_saggrmat_minnrg_asb.F90 similarity index 99% rename from mlprec/mld_saggrmat_minnrg_asb.F90 rename to mlprec/impl/mld_saggrmat_minnrg_asb.F90 index bcd68848..d2703418 100644 --- a/mlprec/mld_saggrmat_minnrg_asb.F90 +++ b/mlprec/impl/mld_saggrmat_minnrg_asb.F90 @@ -83,7 +83,7 @@ ! the fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of the fine-level matrix. -! p - type(mld_sonelev_type), input/output. +! p - type(mld_s_onelev_type), input/output. ! The 'one-level' data structure that will contain the local ! part of the matrix to be built as well as the information ! concerning the prolongator and its transpose. @@ -114,7 +114,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_sonelev_type), intent(inout), target :: p + type(mld_s_onelev_type), intent(inout), target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_saggrmat_nosmth_asb.F90 b/mlprec/impl/mld_saggrmat_nosmth_asb.F90 similarity index 98% rename from mlprec/mld_saggrmat_nosmth_asb.F90 rename to mlprec/impl/mld_saggrmat_nosmth_asb.F90 index bf6ba6c7..771b8dd5 100644 --- a/mlprec/mld_saggrmat_nosmth_asb.F90 +++ b/mlprec/impl/mld_saggrmat_nosmth_asb.F90 @@ -66,7 +66,7 @@ ! the fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of the fine-level matrix. -! p - type(mld_sonelev_type), input/output. +! p - type(mld_s_onelev_type), input/output. ! The 'one-level' data structure that will contain the local ! part of the matrix to be built as well as the information ! concerning the prolongator and its transpose. @@ -97,7 +97,7 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_sonelev_type), intent(inout), target :: p + type(mld_s_onelev_type), intent(inout), target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_saggrmat_smth_asb.F90 b/mlprec/impl/mld_saggrmat_smth_asb.F90 similarity index 99% rename from mlprec/mld_saggrmat_smth_asb.F90 rename to mlprec/impl/mld_saggrmat_smth_asb.F90 index d41f98b6..04a87cc1 100644 --- a/mlprec/mld_saggrmat_smth_asb.F90 +++ b/mlprec/impl/mld_saggrmat_smth_asb.F90 @@ -83,7 +83,7 @@ ! the fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of the fine-level matrix. -! p - type(mld_sonelev_type), input/output. +! p - type(mld_s_onelev_type), input/output. ! The 'one-level' data structure that will contain the local ! part of the matrix to be built as well as the information ! concerning the prolongator and its transpose. @@ -114,7 +114,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_sonelev_type), intent(inout), target :: p + type(mld_s_onelev_type), intent(inout), target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_scoarse_bld.f90 b/mlprec/impl/mld_scoarse_bld.f90 similarity index 98% rename from mlprec/mld_scoarse_bld.f90 rename to mlprec/impl/mld_scoarse_bld.f90 index 0ad7a20b..425b7edb 100644 --- a/mlprec/mld_scoarse_bld.f90 +++ b/mlprec/impl/mld_scoarse_bld.f90 @@ -58,7 +58,7 @@ ! fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of a. -! p - type(mld_sonelev_type), input/output. +! p - type(mld_s_onelev_type), input/output. ! The 'one-level' data structure containing the local part ! of the base preconditioner to be built as well as ! information concerning the prolongator and its transpose. @@ -75,7 +75,7 @@ subroutine mld_scoarse_bld(a,desc_a,p,info) ! Arguments type(psb_sspmat_type), intent(in), target :: a type(psb_desc_type), intent(in), target :: desc_a - type(mld_sonelev_type), intent(inout),target :: p + type(mld_s_onelev_type), intent(inout),target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_silu0_fact.f90 b/mlprec/impl/mld_silu0_fact.f90 similarity index 100% rename from mlprec/mld_silu0_fact.f90 rename to mlprec/impl/mld_silu0_fact.f90 diff --git a/mlprec/mld_siluk_fact.f90 b/mlprec/impl/mld_siluk_fact.f90 similarity index 100% rename from mlprec/mld_siluk_fact.f90 rename to mlprec/impl/mld_siluk_fact.f90 diff --git a/mlprec/mld_silut_fact.f90 b/mlprec/impl/mld_silut_fact.f90 similarity index 100% rename from mlprec/mld_silut_fact.f90 rename to mlprec/impl/mld_silut_fact.f90 diff --git a/mlprec/mld_smlprec_aply.f90 b/mlprec/impl/mld_smlprec_aply.f90 similarity index 100% rename from mlprec/mld_smlprec_aply.f90 rename to mlprec/impl/mld_smlprec_aply.f90 diff --git a/mlprec/mld_smlprec_bld.f90 b/mlprec/impl/mld_smlprec_bld.f90 similarity index 99% rename from mlprec/mld_smlprec_bld.f90 rename to mlprec/impl/mld_smlprec_bld.f90 index 9429ed50..d9d5e9bd 100644 --- a/mlprec/mld_smlprec_bld.f90 +++ b/mlprec/impl/mld_smlprec_bld.f90 @@ -353,7 +353,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) contains subroutine check_coarse_lev(prec) - type(mld_sonelev_type) :: prec + type(mld_s_onelev_type) :: prec ! ! At the coarsest level, check mld_coarse_solve_ diff --git a/mlprec/mld_sprecaply.f90 b/mlprec/impl/mld_sprecaply.f90 similarity index 100% rename from mlprec/mld_sprecaply.f90 rename to mlprec/impl/mld_sprecaply.f90 diff --git a/mlprec/mld_sprecbld.f90 b/mlprec/impl/mld_sprecbld.f90 similarity index 100% rename from mlprec/mld_sprecbld.f90 rename to mlprec/impl/mld_sprecbld.f90 diff --git a/mlprec/mld_sprecinit.F90 b/mlprec/impl/mld_sprecinit.F90 similarity index 100% rename from mlprec/mld_sprecinit.F90 rename to mlprec/impl/mld_sprecinit.F90 diff --git a/mlprec/mld_sprecset.F90 b/mlprec/impl/mld_sprecset.F90 similarity index 99% rename from mlprec/mld_sprecset.F90 rename to mlprec/impl/mld_sprecset.F90 index 1e0e28de..0c8f3fa6 100644 --- a/mlprec/mld_sprecset.F90 +++ b/mlprec/impl/mld_sprecset.F90 @@ -341,7 +341,7 @@ subroutine mld_sprecseti(p,what,val,info,ilev) contains subroutine onelev_set_smoother(level,val,info) - type(mld_sonelev_type), intent(inout) :: level + type(mld_s_onelev_type), intent(inout) :: level integer, intent(in) :: val integer, intent(out) :: info info = psb_success_ @@ -438,7 +438,7 @@ contains end subroutine onelev_set_smoother subroutine onelev_set_solver(level,val,info) - type(mld_sonelev_type), intent(inout) :: level + type(mld_s_onelev_type), intent(inout) :: level integer, intent(in) :: val integer, intent(out) :: info info = psb_success_ diff --git a/mlprec/mld_sslu_bld.f90 b/mlprec/impl/mld_sslu_bld.f90 similarity index 100% rename from mlprec/mld_sslu_bld.f90 rename to mlprec/impl/mld_sslu_bld.f90 diff --git a/mlprec/mld_sslu_interface.c b/mlprec/impl/mld_sslu_interface.c similarity index 100% rename from mlprec/mld_sslu_interface.c rename to mlprec/impl/mld_sslu_interface.c diff --git a/mlprec/mld_sslud_bld.f90 b/mlprec/impl/mld_sslud_bld.f90 similarity index 100% rename from mlprec/mld_sslud_bld.f90 rename to mlprec/impl/mld_sslud_bld.f90 diff --git a/mlprec/mld_sslud_interface.c b/mlprec/impl/mld_sslud_interface.c similarity index 100% rename from mlprec/mld_sslud_interface.c rename to mlprec/impl/mld_sslud_interface.c diff --git a/mlprec/mld_ssp_renum.f90 b/mlprec/impl/mld_ssp_renum.f90 similarity index 100% rename from mlprec/mld_ssp_renum.f90 rename to mlprec/impl/mld_ssp_renum.f90 diff --git a/mlprec/mld_sumf_interface.c b/mlprec/impl/mld_sumf_interface.c similarity index 100% rename from mlprec/mld_sumf_interface.c rename to mlprec/impl/mld_sumf_interface.c diff --git a/mlprec/impl/mld_z_as_smoother_impl.f90 b/mlprec/impl/mld_z_as_smoother_impl.f90 new file mode 100644 index 00000000..3e89cdee --- /dev/null +++ b/mlprec/impl/mld_z_as_smoother_impl.f90 @@ -0,0 +1,1344 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) +!!$ +!!$ (C) Copyright 2008,2009,2010, 2010 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the MLD2P4 group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! +! +! +! +! + +subroutine mld_z_as_smoother_check(sm,info) + + use psb_base_mod + use mld_z_as_smoother, mld_protect_nam => mld_z_as_smoother_check + + Implicit None + + ! Arguments + class(mld_z_as_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='z_as_smoother_check' + + call psb_erractionsave(err_act) + info = psb_success_ + + call mld_check_def(sm%restr,& + & 'Restrictor',psb_halo_,is_legal_restrict) + call mld_check_def(sm%prol,& + & 'Prolongator',psb_none_,is_legal_prolong) + call mld_check_def(sm%novr,& + & 'Overlap layers ',0,is_legal_n_ovr) + + + if (allocated(sm%sv)) then + call sm%sv%check(info) + else + info=3111 + call psb_errpush(info,name) + goto 9999 + end if + + if (info /= psb_success_) goto 9999 + + 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 mld_z_as_smoother_check + +subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + use psb_base_mod + use mld_z_as_smoother, mld_protect_nam => mld_z_as_smoother_apply_vect + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_z_as_smoother_type), intent(inout) :: sm + type(psb_z_vect_type),intent(inout) :: x + type(psb_z_vect_type),intent(inout) :: y + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + integer, intent(in) :: sweeps + complex(psb_dpk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + + integer :: n_row,n_col, nrow_d, i + complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_dpk_), allocatable :: vx(:) + type(psb_z_vect_type) :: vtx, vty, vww + integer :: ictxt,np,me, err_act,isz,int_err(5) + character :: trans_ + character(len=20) :: name='z_as_smoother_apply', ch_err + + call psb_erractionsave(err_act) + + info = psb_success_ + ictxt = desc_data%get_context() + call psb_info(ictxt,me,np) + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T') + case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + if (.not.allocated(sm%sv)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + + n_row = sm%desc_data%get_local_rows() + n_col = sm%desc_data%get_local_cols() + nrow_d = desc_data%get_local_rows() + isz = max(n_row,N_COL) + + if ((6*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + aux => work(3*isz+1:) + else if ((4*isz) <= size(work)) then + aux => work(1:) + allocate(ww(isz),tx(isz),ty(isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + else if ((3*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + allocate(aux(4*isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + else + allocate(ww(isz),tx(isz),ty(isz),& + &aux(4*isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + + endif + + if ((sm%novr == 0).and.(sweeps == 1)) then + ! + ! Shortcut: in this case it's just the same + ! as Block Jacobi. + ! + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + else + + + vx = x%get_vect() + + call psb_geall(vtx,sm%desc_data,info) + call psb_geasb(vtx,sm%desc_data,info,mold=x%v) + call psb_geall(vty,sm%desc_data,info) + call psb_geasb(vty,sm%desc_data,info,mold=x%v) + call psb_geall(vww,sm%desc_data,info) + call psb_geasb(vww,sm%desc_data,info,mold=x%v) + call vtx%set(zzero) + call vty%set(zzero) + call vww%set(zzero) + + + call vtx%set(vx(1:nrow_d)) + + if (sweeps == 1) then + + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx == x) + ! + if (sm%restr == psb_halo_) then + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (sm%prol) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(vtx,sm%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + call sm%sv%apply(zone,vtx,zzero,vty,sm%desc_data,trans_,aux,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + select case(trans_) + case('N') + + select case (sm%prol) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,sm%desc_data,info,& + ! & update=sm%prol,work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(vty,sm%desc_data,info,& + & update=sm%prol,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + if (sm%restr == psb_halo_) then + call psb_ovrl(vty,sm%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + + + else if (sweeps > 1) then + + ! + ! + ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver + ! to compute an approximate solution of a linear system. + ! + ! + call vty%set(zzero) + + do i=1, sweeps + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx == x) + ! + if (sm%restr == psb_halo_) then + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (sm%prol) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(vtx,sm%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + call psb_geaxpby(zone,vtx,zzero,vww,sm%desc_data,info) + call psb_spmm(-zone,sm%nd,vty,zone,vww,sm%desc_data,info,& + & work=aux,trans=trans_) + + if (info /= psb_success_) exit + + call sm%sv%apply(zone,vww,zzero,vty,sm%desc_data,trans_,aux,info) + + if (info /= psb_success_) exit + + + select case(trans_) + case('N') + + select case (sm%prol) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,sm%desc_data,info,& + ! & update=sm%prol,work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(vty,sm%desc_data,info,& + & update=sm%prol,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + if (sm%restr == psb_halo_) then + call psb_ovrl(vty,sm%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + end do + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + + else + + info = psb_err_iarg_neg_ + call psb_errpush(info,name,& + & i_err=(/2,sweeps,0,0,0/)) + goto 9999 + + + end if + + ! + ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) + ! + call psb_geaxpby(alpha,vty,beta,y,desc_data,info) + + end if + + + if ((6*isz) <= size(work)) then + else if ((4*isz) <= size(work)) then + deallocate(ww,tx,ty) + else if ((3*isz) <= size(work)) then + deallocate(aux) + else + deallocate(ww,aux,tx,ty) + endif + call vww%free(info) + call vtx%free(info) + call vty%free(info) + + 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 mld_z_as_smoother_apply_vect + + +subroutine mld_z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + use psb_base_mod + use mld_z_as_smoother, mld_protect_nam => mld_z_as_smoother_apply + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_z_as_smoother_type), intent(in) :: sm + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(inout) :: y(:) + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + integer, intent(in) :: sweeps + complex(psb_dpk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + + integer :: n_row,n_col, nrow_d, i + complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me, err_act,isz,int_err(5) + character :: trans_ + character(len=20) :: name='z_as_smoother_apply', ch_err + + call psb_erractionsave(err_act) + + info = psb_success_ + ictxt = desc_data%get_context() + call psb_info (ictxt,me,np) + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T') + case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + if (.not.allocated(sm%sv)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + + n_row = sm%desc_data%get_local_rows() + n_col = sm%desc_data%get_local_cols() + nrow_d = desc_data%get_local_rows() + isz=max(n_row,N_COL) + if ((6*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + aux => work(3*isz+1:) + else if ((4*isz) <= size(work)) then + aux => work(1:) + allocate(ww(isz),tx(isz),ty(isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + else if ((3*isz) <= size(work)) then + ww => work(1:isz) + tx => work(isz+1:2*isz) + ty => work(2*isz+1:3*isz) + allocate(aux(4*isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + else + allocate(ww(isz),tx(isz),ty(isz),& + &aux(4*isz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + + endif + + if ((sm%novr == 0).and.(sweeps == 1)) then + ! + ! Shortcut: in this case it's just the same + ! as Block Jacobi. + ! + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + else + + + tx(1:nrow_d) = x(1:nrow_d) + tx(nrow_d+1:isz) = zzero + + + if (sweeps == 1) then + + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx == x) + ! + if (sm%restr == psb_halo_) then + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (sm%prol) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(tx,sm%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + call sm%sv%apply(zone,tx,zzero,ty,sm%desc_data,trans_,aux,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + select case(trans_) + case('N') + + select case (sm%prol) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,sm%desc_data,info,& + ! & update=sm%prol,work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(ty,sm%desc_data,info,& + & update=sm%prol,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + if (sm%restr == psb_halo_) then + call psb_ovrl(ty,sm%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + + + + else if (sweeps > 1) then + + ! + ! + ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver + ! to compute an approximate solution of a linear system. + ! + ! + ty = zzero + do i=1, sweeps + select case(trans_) + case('N') + ! + ! Get the overlap entries of tx (tx == x) + ! + if (sm%restr == psb_halo_) then + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + + case('T','C') + ! + ! With transpose, we have to do it here + ! + + select case (sm%prol) + + case(psb_none_) + ! + ! Do nothing + + case(psb_sum_) + ! + ! The transpose of sum is halo + ! + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case(psb_avg_) + ! + ! Tricky one: first we have to scale the overlap entries, + ! which we can do by assignind mode=0, i.e. no communication + ! (hence only scaling), then we do the halo + ! + call psb_ovrl(tx,sm%desc_data,info,& + & update=psb_avg_,work=aux,mode=0) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + ww(1:n_row) = tx(1:n_row) + call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,work=aux,trans=trans_) + + if (info /= psb_success_) exit + + call sm%sv%apply(zone,ww,zzero,ty,sm%desc_data,trans_,aux,info) + + if (info /= psb_success_) exit + + + select case(trans_) + case('N') + + select case (sm%prol) + + case(psb_none_) + ! + ! Would work anyway, but since it is supposed to do nothing ... + ! call psb_ovrl(ty,sm%desc_data,info,& + ! & update=sm%prol,work=aux) + + + case(psb_sum_,psb_avg_) + ! + ! Update the overlap of ty + ! + call psb_ovrl(ty,sm%desc_data,info,& + & update=sm%prol,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') + goto 9999 + end select + + case('T','C') + ! + ! With transpose, we have to do it here + ! + if (sm%restr == psb_halo_) then + call psb_ovrl(ty,sm%desc_data,info,& + & update=psb_sum_,work=aux) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_ovrl' + goto 9999 + end if + else if (sm%restr /= psb_none_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') + goto 9999 + end if + + case default + info=psb_err_iarg_invalid_i_ + int_err(1)=6 + ch_err(2:2)=trans + goto 9999 + end select + end do + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + + else + + info = psb_err_iarg_neg_ + call psb_errpush(info,name,& + & i_err=(/2,sweeps,0,0,0/)) + goto 9999 + + + end if + + ! + ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) + ! + call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + + end if + + + if ((6*isz) <= size(work)) then + else if ((4*isz) <= size(work)) then + deallocate(ww,tx,ty) + else if ((3*isz) <= size(work)) then + deallocate(aux) + else + deallocate(ww,aux,tx,ty) + endif + + 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 mld_z_as_smoother_apply + +subroutine mld_z_as_smoother_bld(a,desc_a,sm,upd,info,amold,vmold) + use psb_base_mod + use mld_z_as_smoother, mld_protect_nam => mld_z_as_smoother_bld + Implicit None + + ! Arguments + type(psb_zspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_z_as_smoother_type), intent(inout) :: sm + character, intent(in) :: upd + integer, intent(out) :: info + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + + ! Local variables + type(psb_zspmat_type) :: blck, atmp + integer :: n_row,n_col, nrow_a, nhalo, novr, data_, nzeros + complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='z_as_smoother_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + novr = sm%novr + if (novr < 0) then + info=psb_err_invalid_ovr_num_ + call psb_errpush(info,name,i_err=(/novr,0,0,0,0,0/)) + goto 9999 + endif + + if ((novr == 0).or.(np == 1)) then + if (psb_toupper(upd) == 'F') then + call psb_cdcpy(desc_a,sm%desc_data,info) + If(debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' done cdcpy' + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_cdcpy' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Early return: P>=3 N_OVR=0' + endif + call blck%csall(0,0,info,1) + else + + If (psb_toupper(upd) == 'F') Then + ! + ! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_). + ! This is done by psb_cdbldext (interface to psb_cdovr), which is + ! independent of CSR, and has been placed in the tools directory + ! of PSBLAS, instead of the mlprec directory of MLD2P4, because it + ! might be used independently of the AS preconditioner, to build + ! a descriptor for an extended stencil in a PDE solver. + ! + call psb_cdbldext(a,desc_a,novr,sm%desc_data,info,extype=psb_ovt_asov_) + if(debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' From cdbldext _:',sm%desc_data%get_local_rows(),& + & sm%desc_data%get_local_cols() + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_cdbldext' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + Endif + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Before sphalo ' + + ! + ! Retrieve the remote sparse matrix rows required for the AS extended + ! matrix + data_ = psb_comm_ext_ + Call psb_sphalo(a,sm%desc_data,blck,info,data=data_,rowscale=.true.) + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sphalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (debug_level >=psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'After psb_sphalo ',& + & blck%get_nrows(), blck%get_nzeros() + + End if + if (info == psb_success_) & + & call sm%sv%build(a,sm%desc_data,upd,info,& + & blck,amold=amold,vmold=vmold) + + nrow_a = a%get_nrows() + n_row = sm%desc_data%get_local_rows() + n_col = sm%desc_data%get_local_cols() + + if (info == psb_success_) call a%csclip(sm%nd,info,& + & jmin=nrow_a+1,rscale=.false.,cscale=.false.) + if (info == psb_success_) call blck%csclip(atmp,info,& + & jmin=nrow_a+1,rscale=.false.,cscale=.false.) + if (info == psb_success_) call psb_rwextd(n_row,sm%nd,info,b=atmp) + + if (info == psb_success_) then + if (present(amold)) then + call sm%nd%cscnv(info,& + & mold=amold,dupl=psb_dupl_add_) + else + call sm%nd%cscnv(info,& + & type='csr',dupl=psb_dupl_add_) + end if + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4') + goto 9999 + end if + nzeros = sm%nd%get_nzeros() +!!$ write(0,*) me,' ND nzeors ',nzeros + call psb_sum(ictxt,nzeros) + sm%nd_nnz_tot = nzeros + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + 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 mld_z_as_smoother_bld + + +subroutine mld_z_as_smoother_seti(sm,what,val,info) + use psb_base_mod + use mld_z_as_smoother, mld_protect_nam => mld_z_as_smoother_seti + Implicit None + + ! Arguments + class(mld_z_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='z_as_smoother_seti' + + info = psb_success_ + 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_) + sm%restr = val + case(mld_sub_prol_) + sm%prol = 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 mld_z_as_smoother_seti + +subroutine mld_z_as_smoother_setc(sm,what,val,info) + use psb_base_mod + use mld_z_as_smoother, mld_protect_nam => mld_z_as_smoother_setc + Implicit None + ! Arguments + class(mld_z_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + character(len=*), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, ival + character(len=20) :: name='z_as_smoother_setc' + + info = psb_success_ + call psb_erractionsave(err_act) + + + call mld_stringval(val,ival,info) + if (info == psb_success_) call sm%set(what,ival,info) + 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 mld_z_as_smoother_setc + +subroutine mld_z_as_smoother_setr(sm,what,val,info) + use psb_base_mod + use mld_z_as_smoother, mld_protect_nam => mld_z_as_smoother_setr + Implicit None + ! Arguments + class(mld_z_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='z_as_smoother_setr' + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (allocated(sm%sv)) then + call sm%sv%set(what,val,info) + else +!!$ write(0,*) trim(name),' Missing component, not setting!' +!!$ info = 1121 + 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 mld_z_as_smoother_setr + +subroutine mld_z_as_smoother_free(sm,info) + use psb_base_mod + use mld_z_as_smoother, mld_protect_nam => mld_z_as_smoother_free + Implicit None + ! Arguments + class(mld_z_as_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='z_as_smoother_free' + + call psb_erractionsave(err_act) + info = psb_success_ + + + + if (allocated(sm%sv)) then + call sm%sv%free(info) + if (info == psb_success_) deallocate(sm%sv,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + end if + call sm%nd%free() + + 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 mld_z_as_smoother_free + +subroutine mld_z_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) + use psb_base_mod + use mld_z_as_smoother, mld_protect_nam => mld_z_as_smoother_dmp + implicit none + class(mld_z_as_smoother_type), intent(in) :: sm + integer, intent(in) :: ictxt,level + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: smoother, solver + integer :: i, j, il1, iln, lname, lev + integer :: icontxt,iam, np + character(len=80) :: prefix_ + character(len=120) :: fname ! len should be at least 20 more than + logical :: smoother_ + ! len of prefix_ + + info = 0 + + if (present(prefix)) then + prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) + else + prefix_ = "dump_smth_z" + end if + + call psb_info(ictxt,iam,np) + + if (present(smoother)) then + smoother_ = smoother + else + smoother_ = .false. + end if + lname = len_trim(prefix_) + fname = trim(prefix_) + write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam + lname = lname + 5 + + if (smoother_) then + write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx' + if (sm%nd%is_asb()) & + & call sm%nd%print(fname,head=head) + end if + ! At base level do nothing for the smoother + if (allocated(sm%sv)) & + & call sm%sv%dump(ictxt,level,info,solver=solver) + +end subroutine mld_z_as_smoother_dmp + diff --git a/mlprec/mld_z_base_smoother_impl.f90 b/mlprec/impl/mld_z_base_smoother_impl.f90 similarity index 99% rename from mlprec/mld_z_base_smoother_impl.f90 rename to mlprec/impl/mld_z_base_smoother_impl.f90 index bbd2b2d2..fc196730 100644 --- a/mlprec/mld_z_base_smoother_impl.f90 +++ b/mlprec/impl/mld_z_base_smoother_impl.f90 @@ -341,7 +341,7 @@ end subroutine mld_z_base_smoother_bld ! subroutine mld_z_base_smoother_free(sm,info) use psb_base_mod - use mld_z_base_smoother_mod, mld_protect_name => s + use mld_z_base_smoother_mod, mld_protect_name => mld_z_base_smoother_free Implicit None ! Arguments diff --git a/mlprec/mld_z_base_solver_impl.f90 b/mlprec/impl/mld_z_base_solver_impl.f90 similarity index 100% rename from mlprec/mld_z_base_solver_impl.f90 rename to mlprec/impl/mld_z_base_solver_impl.f90 diff --git a/mlprec/mld_z_dec_map_bld.F90 b/mlprec/impl/mld_z_dec_map_bld.F90 similarity index 100% rename from mlprec/mld_z_dec_map_bld.F90 rename to mlprec/impl/mld_z_dec_map_bld.F90 diff --git a/mlprec/mld_z_onelev_impl.f90 b/mlprec/impl/mld_z_onelev_impl.f90 similarity index 93% rename from mlprec/mld_z_onelev_impl.f90 rename to mlprec/impl/mld_z_onelev_impl.f90 index 0a937923..5825871b 100644 --- a/mlprec/mld_z_onelev_impl.f90 +++ b/mlprec/impl/mld_z_onelev_impl.f90 @@ -57,10 +57,10 @@ ! subroutine mld_z_base_onelev_descr(lv,il,nl,info,iout) use psb_base_mod - use mld_zonelev_mod, mld_protect_name => mld_z_base_onelev_descr + use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_descr Implicit None ! Arguments - class(mld_zonelev_type), intent(in) :: lv + class(mld_z_onelev_type), intent(in) :: lv integer, intent(in) :: il,nl integer, intent(out) :: info integer, intent(in), optional :: iout @@ -137,10 +137,10 @@ end subroutine mld_z_base_onelev_descr ! subroutine mld_z_base_onelev_free(lv,info) use psb_base_mod - use mld_zonelev_mod, mld_protect_name =>: mld_T_onelev_precfree + use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_free implicit none - class(mld_zonelev_type), intent(inout) :: lv + class(mld_z_onelev_type), intent(inout) :: lv integer, intent(out) :: info integer :: i @@ -175,12 +175,12 @@ end subroutine mld_z_base_onelev_free ! subroutine mld_z_base_onelev_check(lv,info) use psb_base_mod - use mld_zonelev_mod, mld_protect_name => mld_z_base_onelev_check + use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_check Implicit None ! Arguments - class(mld_zonelev_type), intent(inout) :: lv + class(mld_z_onelev_type), intent(inout) :: lv integer, intent(out) :: info Integer :: err_act character(len=20) :: name='z_base_onelev_check' @@ -231,12 +231,12 @@ end subroutine mld_z_base_onelev_check ! subroutine mld_z_base_onelev_seti(lv,what,val,info) use psb_base_mod - use mld_zonelev_mod, mld_protect_name => mld_z_base_onelev_seti + use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_seti Implicit None ! Arguments - class(mld_zonelev_type), intent(inout) :: lv + class(mld_z_onelev_type), intent(inout) :: lv integer, intent(in) :: what integer, intent(in) :: val integer, intent(out) :: info @@ -306,12 +306,12 @@ end subroutine mld_z_base_onelev_seti subroutine mld_z_base_onelev_setc(lv,what,val,info) use psb_base_mod - use mld_zonelev_mod, mld_protect_name => mld_z_base_onelev_setc + use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_setc Implicit None ! Arguments - class(mld_zonelev_type), intent(inout) :: lv + class(mld_z_onelev_type), intent(inout) :: lv integer, intent(in) :: what character(len=*), intent(in) :: val integer, intent(out) :: info @@ -342,12 +342,12 @@ end subroutine mld_z_base_onelev_setc subroutine mld_z_base_onelev_setr(lv,what,val,info) use psb_base_mod - use mld_zonelev_mod, mld_protect_name => mld_z_base_onelev_setr + use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_setr Implicit None ! Arguments - class(mld_zonelev_type), intent(inout) :: lv + class(mld_z_onelev_type), intent(inout) :: lv integer, intent(in) :: what real(psb_dpk_), intent(in) :: val integer, intent(out) :: info @@ -392,9 +392,9 @@ end subroutine mld_z_base_onelev_setr ! subroutine mld_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver) use psb_base_mod - use mld_zonelev_mod, mld_protect_name => mld_z_base_onelev_dump + use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_dump implicit none - class(mld_zonelev_type), intent(in) :: lv + class(mld_z_onelev_type), intent(in) :: lv integer, intent(in) :: level integer, intent(out) :: info character(len=*), intent(in), optional :: prefix, head diff --git a/mlprec/mld_zaggrmap_bld.f90 b/mlprec/impl/mld_zaggrmap_bld.f90 similarity index 100% rename from mlprec/mld_zaggrmap_bld.f90 rename to mlprec/impl/mld_zaggrmap_bld.f90 diff --git a/mlprec/mld_zaggrmat_asb.f90 b/mlprec/impl/mld_zaggrmat_asb.f90 similarity index 98% rename from mlprec/mld_zaggrmat_asb.f90 rename to mlprec/impl/mld_zaggrmat_asb.f90 index c3b0faa6..11d302a6 100644 --- a/mlprec/mld_zaggrmat_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_asb.f90 @@ -83,7 +83,7 @@ ! the fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of the fine-level matrix. -! p - type(mld_zonelev_type), input/output. +! p - type(mld_z_onelev_type), input/output. ! The 'one-level' data structure that will contain the local ! part of the matrix to be built as well as the information ! concerning the prolongator and its transpose. @@ -109,7 +109,7 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_zonelev_type), intent(inout), target :: p + type(mld_z_onelev_type), intent(inout), target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_zaggrmat_minnrg_asb.F90 b/mlprec/impl/mld_zaggrmat_minnrg_asb.F90 similarity index 99% rename from mlprec/mld_zaggrmat_minnrg_asb.F90 rename to mlprec/impl/mld_zaggrmat_minnrg_asb.F90 index 796b0fdc..f176ec67 100644 --- a/mlprec/mld_zaggrmat_minnrg_asb.F90 +++ b/mlprec/impl/mld_zaggrmat_minnrg_asb.F90 @@ -83,7 +83,7 @@ ! the fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of the fine-level matrix. -! p - type(mld_zonelev_type), input/output. +! p - type(mld_z_onelev_type), input/output. ! The 'one-level' data structure that will contain the local ! part of the matrix to be built as well as the information ! concerning the prolongator and its transpose. @@ -114,7 +114,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_zonelev_type), intent(inout), target :: p + type(mld_z_onelev_type), intent(inout), target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_zaggrmat_nosmth_asb.F90 b/mlprec/impl/mld_zaggrmat_nosmth_asb.F90 similarity index 98% rename from mlprec/mld_zaggrmat_nosmth_asb.F90 rename to mlprec/impl/mld_zaggrmat_nosmth_asb.F90 index 9cf9020f..5123826e 100644 --- a/mlprec/mld_zaggrmat_nosmth_asb.F90 +++ b/mlprec/impl/mld_zaggrmat_nosmth_asb.F90 @@ -66,7 +66,7 @@ ! the fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of the fine-level matrix. -! p - type(mld_zonelev_type), input/output. +! p - type(mld_z_onelev_type), input/output. ! The 'one-level' data structure that will contain the local ! part of the matrix to be built as well as the information ! concerning the prolongator and its transpose. @@ -97,7 +97,7 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_zonelev_type), intent(inout), target :: p + type(mld_z_onelev_type), intent(inout), target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_zaggrmat_smth_asb.F90 b/mlprec/impl/mld_zaggrmat_smth_asb.F90 similarity index 99% rename from mlprec/mld_zaggrmat_smth_asb.F90 rename to mlprec/impl/mld_zaggrmat_smth_asb.F90 index fc9cae35..805970dc 100644 --- a/mlprec/mld_zaggrmat_smth_asb.F90 +++ b/mlprec/impl/mld_zaggrmat_smth_asb.F90 @@ -83,7 +83,7 @@ ! the fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of the fine-level matrix. -! p - type(mld_zonelev_type), input/output. +! p - type(mld_z_onelev_type), input/output. ! The 'one-level' data structure that will contain the local ! part of the matrix to be built as well as the information ! concerning the prolongator and its transpose. @@ -114,7 +114,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_zonelev_type), intent(inout), target :: p + type(mld_z_onelev_type), intent(inout), target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_zcoarse_bld.f90 b/mlprec/impl/mld_zcoarse_bld.f90 similarity index 98% rename from mlprec/mld_zcoarse_bld.f90 rename to mlprec/impl/mld_zcoarse_bld.f90 index c5067d15..e7f9ebfa 100644 --- a/mlprec/mld_zcoarse_bld.f90 +++ b/mlprec/impl/mld_zcoarse_bld.f90 @@ -58,7 +58,7 @@ ! fine-level matrix. ! desc_a - type(psb_desc_type), input. ! The communication descriptor of a. -! p - type(mld_zonelev_type), input/output. +! p - type(mld_z_onelev_type), input/output. ! The 'one-level' data structure containing the local part ! of the base preconditioner to be built as well as ! information concerning the prolongator and its transpose. @@ -75,7 +75,7 @@ subroutine mld_zcoarse_bld(a,desc_a,p,info) ! Arguments type(psb_zspmat_type), intent(in), target :: a type(psb_desc_type), intent(in), target :: desc_a - type(mld_zonelev_type), intent(inout),target :: p + type(mld_z_onelev_type), intent(inout),target :: p integer, intent(out) :: info ! Local variables diff --git a/mlprec/mld_zilu0_fact.f90 b/mlprec/impl/mld_zilu0_fact.f90 similarity index 100% rename from mlprec/mld_zilu0_fact.f90 rename to mlprec/impl/mld_zilu0_fact.f90 diff --git a/mlprec/mld_ziluk_fact.f90 b/mlprec/impl/mld_ziluk_fact.f90 similarity index 100% rename from mlprec/mld_ziluk_fact.f90 rename to mlprec/impl/mld_ziluk_fact.f90 diff --git a/mlprec/mld_zilut_fact.f90 b/mlprec/impl/mld_zilut_fact.f90 similarity index 100% rename from mlprec/mld_zilut_fact.f90 rename to mlprec/impl/mld_zilut_fact.f90 diff --git a/mlprec/mld_zmlprec_aply.f90 b/mlprec/impl/mld_zmlprec_aply.f90 similarity index 100% rename from mlprec/mld_zmlprec_aply.f90 rename to mlprec/impl/mld_zmlprec_aply.f90 diff --git a/mlprec/mld_zmlprec_bld.f90 b/mlprec/impl/mld_zmlprec_bld.f90 similarity index 99% rename from mlprec/mld_zmlprec_bld.f90 rename to mlprec/impl/mld_zmlprec_bld.f90 index fa84047e..86e5d77b 100644 --- a/mlprec/mld_zmlprec_bld.f90 +++ b/mlprec/impl/mld_zmlprec_bld.f90 @@ -353,7 +353,7 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) contains subroutine check_coarse_lev(prec) - type(mld_zonelev_type) :: prec + type(mld_z_onelev_type) :: prec ! ! At the coarsest level, check mld_coarse_solve_ diff --git a/mlprec/mld_zprecaply.f90 b/mlprec/impl/mld_zprecaply.f90 similarity index 100% rename from mlprec/mld_zprecaply.f90 rename to mlprec/impl/mld_zprecaply.f90 diff --git a/mlprec/mld_zprecbld.f90 b/mlprec/impl/mld_zprecbld.f90 similarity index 100% rename from mlprec/mld_zprecbld.f90 rename to mlprec/impl/mld_zprecbld.f90 diff --git a/mlprec/mld_zprecinit.F90 b/mlprec/impl/mld_zprecinit.F90 similarity index 100% rename from mlprec/mld_zprecinit.F90 rename to mlprec/impl/mld_zprecinit.F90 diff --git a/mlprec/mld_zprecset.F90 b/mlprec/impl/mld_zprecset.F90 similarity index 99% rename from mlprec/mld_zprecset.F90 rename to mlprec/impl/mld_zprecset.F90 index 2d928de4..c49244ac 100644 --- a/mlprec/mld_zprecset.F90 +++ b/mlprec/impl/mld_zprecset.F90 @@ -341,7 +341,7 @@ subroutine mld_zprecseti(p,what,val,info,ilev) contains subroutine onelev_set_smoother(level,val,info) - type(mld_zonelev_type), intent(inout) :: level + type(mld_z_onelev_type), intent(inout) :: level integer, intent(in) :: val integer, intent(out) :: info info = psb_success_ @@ -438,7 +438,7 @@ contains end subroutine onelev_set_smoother subroutine onelev_set_solver(level,val,info) - type(mld_zonelev_type), intent(inout) :: level + type(mld_z_onelev_type), intent(inout) :: level integer, intent(in) :: val integer, intent(out) :: info info = psb_success_ diff --git a/mlprec/mld_zslu_bld.f90 b/mlprec/impl/mld_zslu_bld.f90 similarity index 100% rename from mlprec/mld_zslu_bld.f90 rename to mlprec/impl/mld_zslu_bld.f90 diff --git a/mlprec/mld_zslu_interface.c b/mlprec/impl/mld_zslu_interface.c similarity index 100% rename from mlprec/mld_zslu_interface.c rename to mlprec/impl/mld_zslu_interface.c diff --git a/mlprec/mld_zslud_bld.f90 b/mlprec/impl/mld_zslud_bld.f90 similarity index 100% rename from mlprec/mld_zslud_bld.f90 rename to mlprec/impl/mld_zslud_bld.f90 diff --git a/mlprec/mld_zslud_interface.c b/mlprec/impl/mld_zslud_interface.c similarity index 100% rename from mlprec/mld_zslud_interface.c rename to mlprec/impl/mld_zslud_interface.c diff --git a/mlprec/mld_zsp_renum.f90 b/mlprec/impl/mld_zsp_renum.f90 similarity index 100% rename from mlprec/mld_zsp_renum.f90 rename to mlprec/impl/mld_zsp_renum.f90 diff --git a/mlprec/mld_zumf_interface.c b/mlprec/impl/mld_zumf_interface.c similarity index 100% rename from mlprec/mld_zumf_interface.c rename to mlprec/impl/mld_zumf_interface.c diff --git a/mlprec/mld_c_as_smoother.f90 b/mlprec/mld_c_as_smoother.f90 index 5da6fe27..fca84f42 100644 --- a/mlprec/mld_c_as_smoother.f90 +++ b/mlprec/mld_c_as_smoother.f90 @@ -55,15 +55,15 @@ module mld_c_as_smoother type(psb_desc_type) :: desc_data integer :: novr, restr, prol, nd_nnz_tot contains - procedure, pass(sm) :: check => c_as_smoother_check - procedure, pass(sm) :: dump => c_as_smoother_dmp - procedure, pass(sm) :: build => c_as_smoother_bld - procedure, pass(sm) :: apply_v => c_as_smoother_apply_vect - procedure, pass(sm) :: apply_a => c_as_smoother_apply - procedure, pass(sm) :: free => c_as_smoother_free - procedure, pass(sm) :: seti => c_as_smoother_seti - procedure, pass(sm) :: setc => c_as_smoother_setc - procedure, pass(sm) :: setr => c_as_smoother_setr + procedure, pass(sm) :: check => mld_c_as_smoother_check + procedure, pass(sm) :: dump => mld_c_as_smoother_dmp + procedure, pass(sm) :: build => mld_c_as_smoother_bld + procedure, pass(sm) :: apply_v => mld_c_as_smoother_apply_vect + procedure, pass(sm) :: apply_a => mld_c_as_smoother_apply + 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) :: descr => c_as_smoother_descr procedure, pass(sm) :: sizeof => c_as_smoother_sizeof procedure, pass(sm) :: default => c_as_smoother_default @@ -71,13 +71,8 @@ module mld_c_as_smoother end type mld_c_as_smoother_type - private :: c_as_smoother_bld, c_as_smoother_apply, & - & c_as_smoother_free, c_as_smoother_seti, & - & c_as_smoother_setc, c_as_smoother_setr,& - & c_as_smoother_descr, c_as_smoother_sizeof, & - & c_as_smoother_check, c_as_smoother_default,& - & c_as_smoother_dmp, c_as_smoother_apply_vect,& - & c_as_smoother_get_nzeros + private :: c_as_smoother_descr, c_as_smoother_sizeof, & + & c_as_smoother_default, c_as_smoother_get_nzeros character(len=6), parameter, private :: & & restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/) @@ -85,1284 +80,166 @@ module mld_c_as_smoother & prolong_names(0:3)=(/'none ','sum ','average ','square root'/) + interface mld_c_as_smoother_check + subroutine mld_c_as_smoother_check(sm,info) + import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & + & psb_spk_, mld_c_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_c_as_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + end subroutine mld_c_as_smoother_check + end interface mld_c_as_smoother_check + + interface mld_c_as_smoother_apply_vect + subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & + & psb_spk_, mld_c_as_smoother_type, psb_long_int_k_, psb_desc_type + type(psb_desc_type), intent(in) :: desc_data + class(mld_c_as_smoother_type), intent(inout) :: sm + type(psb_c_vect_type),intent(inout) :: x + type(psb_c_vect_type),intent(inout) :: y + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + integer, intent(in) :: sweeps + complex(psb_spk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + end subroutine mld_c_as_smoother_apply_vect + end interface mld_c_as_smoother_apply_vect + + interface mld_c_as_smoother_apply + subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & + & psb_spk_, mld_c_as_smoother_type, psb_long_int_k_, psb_desc_type + type(psb_desc_type), intent(in) :: desc_data + class(mld_c_as_smoother_type), intent(in) :: sm + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + integer, intent(in) :: sweeps + complex(psb_spk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + end subroutine mld_c_as_smoother_apply + end interface mld_c_as_smoother_apply + + interface mld_c_as_smoother_bld + subroutine mld_c_as_smoother_bld(a,desc_a,sm,upd,info,amold,vmold) + import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & + & psb_spk_, mld_c_as_smoother_type, psb_long_int_k_, & + & psb_desc_type, psb_c_base_sparse_mat + type(psb_cspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_c_as_smoother_type), intent(inout) :: sm + character, intent(in) :: upd + integer, intent(out) :: info + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + end subroutine mld_c_as_smoother_bld + end interface mld_c_as_smoother_bld + + interface mld_c_as_smoother_seti + subroutine mld_c_as_smoother_seti(sm,what,val,info) + import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & + & psb_spk_, mld_c_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_c_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + end subroutine mld_c_as_smoother_seti + end interface mld_c_as_smoother_seti + + interface mld_c_as_smoother_setc + subroutine mld_c_as_smoother_setc(sm,what,val,info) + import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & + & psb_spk_, mld_c_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_c_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + character(len=*), intent(in) :: val + integer, intent(out) :: info + end subroutine mld_c_as_smoother_setc + end interface mld_c_as_smoother_setc + + interface mld_c_as_smoother_setr + subroutine mld_c_as_smoother_setr(sm,what,val,info) + import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & + & psb_spk_, mld_c_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_c_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + end subroutine mld_c_as_smoother_setr + end interface mld_c_as_smoother_setr + + interface mld_c_as_smoother_free + subroutine mld_c_as_smoother_free(sm,info) + import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & + & psb_spk_, mld_c_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_c_as_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + end subroutine mld_c_as_smoother_free + end interface mld_c_as_smoother_free + + interface mld_c_as_smoother_dmp + subroutine mld_c_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) + import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & + & psb_spk_, mld_c_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_c_as_smoother_type), intent(in) :: sm + integer, intent(in) :: ictxt,level + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: smoother, solver + end subroutine mld_c_as_smoother_dmp + end interface mld_c_as_smoother_dmp + contains - subroutine c_as_smoother_default(sm) - - use psb_base_mod - - Implicit None - - ! Arguments - class(mld_c_as_smoother_type), intent(inout) :: sm - - - sm%restr = psb_halo_ - sm%prol = psb_none_ - sm%novr = 1 - - - if (allocated(sm%sv)) then - call sm%sv%default() - end if - - return - end subroutine c_as_smoother_default - - subroutine c_as_smoother_check(sm,info) - - use psb_base_mod - - Implicit None - + function c_as_smoother_sizeof(sm) result(val) + implicit none ! Arguments - class(mld_c_as_smoother_type), intent(inout) :: sm - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='c_as_smoother_check' - - call psb_erractionsave(err_act) - info = psb_success_ - - call mld_check_def(sm%restr,& - & 'Restrictor',psb_halo_,is_legal_restrict) - call mld_check_def(sm%prol,& - & 'Prolongator',psb_none_,is_legal_prolong) - call mld_check_def(sm%novr,& - & 'Overlap layers ',0,is_legal_n_ovr) - - - if (allocated(sm%sv)) then - call sm%sv%check(info) - else - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - - if (info /= psb_success_) goto 9999 - - 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_as_smoother_check - - subroutine c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - use psb_base_mod - type(psb_desc_type), intent(in) :: desc_data - class(mld_c_as_smoother_type), intent(inout) :: sm - type(psb_c_vect_type),intent(inout) :: x - type(psb_c_vect_type),intent(inout) :: y - complex(psb_spk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans - integer, intent(in) :: sweeps - complex(psb_spk_),target, intent(inout) :: work(:) - integer, intent(out) :: info - - integer :: n_row,n_col, nrow_d, i - complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) - complex(psb_spk_), allocatable :: vx(:) - type(psb_c_vect_type) :: vtx, vty, vww - integer :: ictxt,np,me, err_act,isz,int_err(5) - character :: trans_ - character(len=20) :: name='c_as_smoother_apply', ch_err - - call psb_erractionsave(err_act) - - info = psb_success_ - ictxt = desc_data%get_context() - call psb_info(ictxt,me,np) - - trans_ = psb_toupper(trans) - select case(trans_) - case('N') - case('T') - case('C') - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select - - if (.not.allocated(sm%sv)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - - n_row = sm%desc_data%get_local_rows() - n_col = sm%desc_data%get_local_cols() - nrow_d = desc_data%get_local_rows() - isz = max(n_row,N_COL) - - if ((6*isz) <= size(work)) then - ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) - aux => work(3*isz+1:) - else if ((4*isz) <= size(work)) then - aux => work(1:) - allocate(ww(isz),tx(isz),ty(isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),& - & a_err='complex(psb_spk_)') - goto 9999 - end if - else if ((3*isz) <= size(work)) then - ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) - allocate(aux(4*isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& - & a_err='complex(psb_spk_)') - goto 9999 - end if - else - allocate(ww(isz),tx(isz),ty(isz),& - &aux(4*isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& - & a_err='complex(psb_spk_)') - goto 9999 - end if - - endif - - if ((sm%novr == 0).and.(sweeps == 1)) then - ! - ! Shortcut: in this case it's just the same - ! as Block Jacobi. - ! - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') - goto 9999 - endif - - else - - - vx = x%get_vect() - - call psb_geall(vtx,sm%desc_data,info) - call psb_geasb(vtx,sm%desc_data,info,mold=x%v) - call psb_geall(vty,sm%desc_data,info) - call psb_geasb(vty,sm%desc_data,info,mold=x%v) - call psb_geall(vww,sm%desc_data,info) - call psb_geasb(vww,sm%desc_data,info,mold=x%v) - call vtx%set(czero) - call vty%set(czero) - call vww%set(czero) - - - call vtx%set(vx(1:nrow_d)) - - if (sweeps == 1) then - - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (sm%restr == psb_halo_) then - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - - case('T','C') - ! - ! With transpose, we have to do it here - ! - - select case (sm%prol) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case(psb_avg_) - ! - ! Tricky one: first we have to scale the overlap entries, - ! which we can do by assignind mode=0, i.e. no communication - ! (hence only scaling), then we do the halo - ! - call psb_ovrl(vtx,sm%desc_data,info,& - & update=psb_avg_,work=aux,mode=0) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - call sm%sv%apply(cone,vtx,czero,vty,sm%desc_data,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') - goto 9999 - endif - - select case(trans_) - case('N') - - select case (sm%prol) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,sm%desc_data,info,& - ! & update=sm%prol,work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(vty,sm%desc_data,info,& - & update=sm%prol,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - case('T','C') - ! - ! With transpose, we have to do it here - ! - if (sm%restr == psb_halo_) then - call psb_ovrl(vty,sm%desc_data,info,& - & update=psb_sum_,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - - - else if (sweeps > 1) then - - ! - ! - ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver - ! to compute an approximate solution of a linear system. - ! - ! - call vty%set(czero) - - do i=1, sweeps - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (sm%restr == psb_halo_) then - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - - case('T','C') - ! - ! With transpose, we have to do it here - ! - - select case (sm%prol) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case(psb_avg_) - ! - ! Tricky one: first we have to scale the overlap entries, - ! which we can do by assignind mode=0, i.e. no communication - ! (hence only scaling), then we do the halo - ! - call psb_ovrl(vtx,sm%desc_data,info,& - & update=psb_avg_,work=aux,mode=0) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - ! - ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the - ! block diagonal part and the remaining part of the local matrix - ! and Y(j) is the approximate solution at sweep j. - ! - call psb_geaxpby(cone,vtx,czero,vww,sm%desc_data,info) - call psb_spmm(-cone,sm%nd,vty,cone,vww,sm%desc_data,info,& - & work=aux,trans=trans_) - - if (info /= psb_success_) exit - - call sm%sv%apply(cone,vww,czero,vty,sm%desc_data,trans_,aux,info) - - if (info /= psb_success_) exit - - - select case(trans_) - case('N') - - select case (sm%prol) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,sm%desc_data,info,& - ! & update=sm%prol,work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(vty,sm%desc_data,info,& - & update=sm%prol,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - case('T','C') - ! - ! With transpose, we have to do it here - ! - if (sm%restr == psb_halo_) then - call psb_ovrl(vty,sm%desc_data,info,& - & update=psb_sum_,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - end do - - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 - end if - - - else - - info = psb_err_iarg_neg_ - call psb_errpush(info,name,& - & i_err=(/2,sweeps,0,0,0/)) - goto 9999 - - - end if - - ! - ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) - ! - call psb_geaxpby(alpha,vty,beta,y,desc_data,info) - - end if - - - if ((6*isz) <= size(work)) then - else if ((4*isz) <= size(work)) then - deallocate(ww,tx,ty) - else if ((3*isz) <= size(work)) then - deallocate(aux) - else - deallocate(ww,aux,tx,ty) - endif - call vww%free(info) - call vtx%free(info) - call vty%free(info) - - 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_as_smoother_apply_vect - - - subroutine c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - use psb_base_mod - type(psb_desc_type), intent(in) :: desc_data class(mld_c_as_smoother_type), intent(in) :: sm - complex(psb_spk_),intent(inout) :: x(:) - complex(psb_spk_),intent(inout) :: y(:) - complex(psb_spk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans - integer, intent(in) :: sweeps - complex(psb_spk_),target, intent(inout) :: work(:) - integer, intent(out) :: info - - integer :: n_row,n_col, nrow_d, i - complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) - integer :: ictxt,np,me, err_act,isz,int_err(5) - character :: trans_ - character(len=20) :: name='c_as_smoother_apply', ch_err - - call psb_erractionsave(err_act) - - info = psb_success_ - ictxt = desc_data%get_context() - call psb_info (ictxt,me,np) - - trans_ = psb_toupper(trans) - select case(trans_) - case('N') - case('T') - case('C') - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select - - if (.not.allocated(sm%sv)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - - n_row = sm%desc_data%get_local_rows() - n_col = sm%desc_data%get_local_cols() - nrow_d = desc_data%get_local_rows() - isz=max(n_row,N_COL) - if ((6*isz) <= size(work)) then - ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) - aux => work(3*isz+1:) - else if ((4*isz) <= size(work)) then - aux => work(1:) - allocate(ww(isz),tx(isz),ty(isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),& - & a_err='complex(psb_spk_)') - goto 9999 - end if - else if ((3*isz) <= size(work)) then - ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) - allocate(aux(4*isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& - & a_err='complex(psb_spk_)') - goto 9999 - end if - else - allocate(ww(isz),tx(isz),ty(isz),& - &aux(4*isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& - & a_err='complex(psb_spk_)') - goto 9999 - end if - - endif - - if ((sm%novr == 0).and.(sweeps == 1)) then - ! - ! Shortcut: in this case it's just the same - ! as Block Jacobi. - ! - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') - goto 9999 - endif - - else - - - tx(1:nrow_d) = x(1:nrow_d) - tx(nrow_d+1:isz) = czero - - - if (sweeps == 1) then - - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (sm%restr == psb_halo_) then - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - - case('T','C') - ! - ! With transpose, we have to do it here - ! - - select case (sm%prol) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case(psb_avg_) - ! - ! Tricky one: first we have to scale the overlap entries, - ! which we can do by assignind mode=0, i.e. no communication - ! (hence only scaling), then we do the halo - ! - call psb_ovrl(tx,sm%desc_data,info,& - & update=psb_avg_,work=aux,mode=0) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - call sm%sv%apply(cone,tx,czero,ty,sm%desc_data,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') - goto 9999 - endif - - select case(trans_) - case('N') - - select case (sm%prol) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,sm%desc_data,info,& - ! & update=sm%prol,work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(ty,sm%desc_data,info,& - & update=sm%prol,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - case('T','C') - ! - ! With transpose, we have to do it here - ! - if (sm%restr == psb_halo_) then - call psb_ovrl(ty,sm%desc_data,info,& - & update=psb_sum_,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - - - else if (sweeps > 1) then - - ! - ! - ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver - ! to compute an approximate solution of a linear system. - ! - ! - ty = czero - do i=1, sweeps - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (sm%restr == psb_halo_) then - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - - case('T','C') - ! - ! With transpose, we have to do it here - ! - - select case (sm%prol) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case(psb_avg_) - ! - ! Tricky one: first we have to scale the overlap entries, - ! which we can do by assignind mode=0, i.e. no communication - ! (hence only scaling), then we do the halo - ! - call psb_ovrl(tx,sm%desc_data,info,& - & update=psb_avg_,work=aux,mode=0) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - ! - ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the - ! block diagonal part and the remaining part of the local matrix - ! and Y(j) is the approximate solution at sweep j. - ! - ww(1:n_row) = tx(1:n_row) - call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,work=aux,trans=trans_) - - if (info /= psb_success_) exit - - call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info) - - if (info /= psb_success_) exit - - - select case(trans_) - case('N') - - select case (sm%prol) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,sm%desc_data,info,& - ! & update=sm%prol,work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(ty,sm%desc_data,info,& - & update=sm%prol,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - case('T','C') - ! - ! With transpose, we have to do it here - ! - if (sm%restr == psb_halo_) then - call psb_ovrl(ty,sm%desc_data,info,& - & update=psb_sum_,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - end do - - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1') - goto 9999 - end if - - - else - - info = psb_err_iarg_neg_ - call psb_errpush(info,name,& - & i_err=(/2,sweeps,0,0,0/)) - goto 9999 - - - end if - - ! - ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) - ! - call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - - end if - - - if ((6*isz) <= size(work)) then - else if ((4*isz) <= size(work)) then - deallocate(ww,tx,ty) - else if ((3*isz) <= size(work)) then - deallocate(aux) - else - deallocate(ww,aux,tx,ty) - endif - - 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_as_smoother_apply - - subroutine c_as_smoother_bld(a,desc_a,sm,upd,info,amold,vmold) - - use psb_base_mod - - Implicit None - - ! Arguments - type(psb_cspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(in) :: desc_a - class(mld_c_as_smoother_type), intent(inout) :: sm - character, intent(in) :: upd - integer, intent(out) :: info - class(psb_c_base_sparse_mat), intent(in), optional :: amold - class(psb_c_base_vect_type), intent(in), optional :: vmold - - ! Local variables - type(psb_cspmat_type) :: blck, atmp - integer :: n_row,n_col, nrow_a, nhalo, novr, data_, nzeros - complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) - integer :: ictxt,np,me,i, err_act, debug_unit, debug_level - character(len=20) :: name='c_as_smoother_bld', ch_err - - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),' start' - - - novr = sm%novr - if (novr < 0) then - info=psb_err_invalid_ovr_num_ - call psb_errpush(info,name,i_err=(/novr,0,0,0,0,0/)) - goto 9999 - endif - - if ((novr == 0).or.(np == 1)) then - if (psb_toupper(upd) == 'F') then - call psb_cdcpy(desc_a,sm%desc_data,info) - If(debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' cone cdcpy' - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_cdcpy' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Early return: P>=3 N_OVR=0' - endif - call blck%csall(0,0,info,1) - else - - If (psb_toupper(upd) == 'F') Then - ! - ! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_). - ! This is cone by psb_cdbldext (interface to psb_cdovr), which is - ! independent of CSR, and has been placed in the tools directory - ! of PSBLAS, instead of the mlprec directory of MLD2P4, because it - ! might be used independently of the AS preconditioner, to build - ! a descriptor for an extended stencil in a PDE solver. - ! - call psb_cdbldext(a,desc_a,novr,sm%desc_data,info,extype=psb_ovt_asov_) - if(debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' From cdbldext _:',sm%desc_data%get_local_rows(),& - & sm%desc_data%get_local_cols() - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_cdbldext' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - Endif - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Before sphalo ' - - ! - ! Retrieve the remote sparse matrix rows required for the AS extended - ! matrix - data_ = psb_comm_ext_ - Call psb_sphalo(a,sm%desc_data,blck,info,data=data_,rowscale=.true.) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sphalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if (debug_level >=psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'After psb_sphalo ',& - & blck%get_nrows(), blck%get_nzeros() - - End if - if (info == psb_success_) & - & call sm%sv%build(a,sm%desc_data,upd,info,& - & blck,amold=amold,vmold=vmold) - - nrow_a = a%get_nrows() - n_row = sm%desc_data%get_local_rows() - n_col = sm%desc_data%get_local_cols() - - if (info == psb_success_) call a%csclip(sm%nd,info,& - & jmin=nrow_a+1,rscale=.false.,cscale=.false.) - if (info == psb_success_) call blck%csclip(atmp,info,& - & jmin=nrow_a+1,rscale=.false.,cscale=.false.) - if (info == psb_success_) call psb_rwextd(n_row,sm%nd,info,b=atmp) - - if (info == psb_success_) then - if (present(amold)) then - call sm%nd%cscnv(info,& - & mold=amold,dupl=psb_dupl_add_) - else - call sm%nd%cscnv(info,& - & type='csr',dupl=psb_dupl_add_) - end if - end if - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4') - goto 9999 - end if - nzeros = sm%nd%get_nzeros() -!!$ write(0,*) me,' ND nzeors ',nzeros - call psb_sum(ictxt,nzeros) - sm%nd_nnz_tot = nzeros - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),' end' - - 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_as_smoother_bld - - - subroutine c_as_smoother_seti(sm,what,val,info) - - use psb_base_mod - - Implicit None - - ! Arguments - class(mld_c_as_smoother_type), intent(inout) :: sm - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='c_as_smoother_seti' - - info = psb_success_ - 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_) - sm%restr = val - case(mld_sub_prol_) - sm%prol = val - case default - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if - end select + integer(psb_long_int_k_) :: val + integer :: i - call psb_erractionrestore(err_act) - return + val = psb_sizeof_int + if (allocated(sm%sv)) val = val + sm%sv%sizeof() + val = val + sm%nd%sizeof() -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return - end subroutine c_as_smoother_seti - - subroutine c_as_smoother_setc(sm,what,val,info) - - use psb_base_mod - - Implicit None - - ! Arguments - class(mld_c_as_smoother_type), intent(inout) :: sm - integer, intent(in) :: what - character(len=*), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, ival - character(len=20) :: name='c_as_smoother_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - - call mld_stringval(val,ival,info) - if (info == psb_success_) call sm%set(what,ival,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info, name) - goto 9999 - end if + end function c_as_smoother_sizeof - call psb_erractionrestore(err_act) - return + function c_as_smoother_get_nzeros(sm) result(val) + implicit none + class(mld_c_as_smoother_type), intent(in) :: sm + integer(psb_long_int_k_) :: val + integer :: i + val = 0 + if (allocated(sm%sv)) & + & val = sm%sv%get_nzeros() + val = val + sm%nd%get_nzeros() -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine c_as_smoother_setc + end function c_as_smoother_get_nzeros - subroutine c_as_smoother_setr(sm,what,val,info) + subroutine c_as_smoother_default(sm) - use psb_base_mod + use psb_base_mod, only : psb_halo_, psb_none_ Implicit None ! Arguments class(mld_c_as_smoother_type), intent(inout) :: sm - integer, intent(in) :: what - real(psb_spk_), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='c_as_smoother_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - else -!!$ write(0,*) trim(name),' Missing component, not setting!' -!!$ info = 1121 - 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_as_smoother_setr - - subroutine c_as_smoother_free(sm,info) - - use psb_base_mod - - Implicit None - - ! Arguments - class(mld_c_as_smoother_type), intent(inout) :: sm - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='c_as_smoother_free' - - call psb_erractionsave(err_act) - info = psb_success_ + sm%restr = psb_halo_ + sm%prol = psb_none_ + sm%novr = 1 if (allocated(sm%sv)) then - call sm%sv%free(info) - if (info == psb_success_) deallocate(sm%sv,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + call sm%sv%default() end if - call sm%nd%free() - call psb_erractionrestore(err_act) return + end subroutine c_as_smoother_default -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine c_as_smoother_free subroutine c_as_smoother_descr(sm,info,iout,coarse) @@ -1419,77 +296,4 @@ contains return end subroutine c_as_smoother_descr - function c_as_smoother_sizeof(sm) result(val) - use psb_base_mod - implicit none - ! Arguments - class(mld_c_as_smoother_type), intent(in) :: sm - integer(psb_long_int_k_) :: val - integer :: i - - val = psb_sizeof_int - if (allocated(sm%sv)) val = val + sm%sv%sizeof() - val = val + sm%nd%sizeof() - - return - end function c_as_smoother_sizeof - - function c_as_smoother_get_nzeros(sm) result(val) - implicit none - class(mld_c_as_smoother_type), intent(in) :: sm - integer(psb_long_int_k_) :: val - integer :: i - val = 0 - if (allocated(sm%sv)) & - & val = sm%sv%get_nzeros() - val = val + sm%nd%get_nzeros() - - end function c_as_smoother_get_nzeros - - subroutine c_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) - use psb_base_mod - implicit none - class(mld_c_as_smoother_type), intent(in) :: sm - integer, intent(in) :: ictxt,level - integer, intent(out) :: info - character(len=*), intent(in), optional :: prefix, head - logical, optional, intent(in) :: smoother, solver - integer :: i, j, il1, iln, lname, lev - integer :: icontxt,iam, np - character(len=80) :: prefix_ - character(len=120) :: fname ! len should be at least 20 more than - logical :: smoother_ - ! len of prefix_ - - info = 0 - - if (present(prefix)) then - prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) - else - prefix_ = "dump_smth_d" - end if - - call psb_info(ictxt,iam,np) - - if (present(smoother)) then - smoother_ = smoother - else - smoother_ = .false. - end if - lname = len_trim(prefix_) - fname = trim(prefix_) - write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam - lname = lname + 5 - - if (smoother_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx' - if (sm%nd%is_asb()) & - & call sm%nd%print(fname,head=head) - end if - ! At base level do nothing for the smoother - if (allocated(sm%sv)) & - & call sm%sv%dump(ictxt,level,info,solver=solver) - - end subroutine c_as_smoother_dmp - end module mld_c_as_smoother diff --git a/mlprec/mld_c_inner_mod.f90 b/mlprec/mld_c_inner_mod.f90 index 62d7d660..5f47270c 100644 --- a/mlprec/mld_c_inner_mod.f90 +++ b/mlprec/mld_c_inner_mod.f90 @@ -98,10 +98,10 @@ module mld_c_inner_mod interface mld_coarse_bld subroutine mld_ccoarse_bld(a,desc_a,p,info) use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ - use mld_c_prec_type, only : mld_conelev_type + use mld_c_prec_type, only : mld_c_onelev_type type(psb_cspmat_type), intent(in), target :: a type(psb_desc_type), intent(in), target :: desc_a - type(mld_conelev_type), intent(inout), target :: p + type(mld_c_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_ccoarse_bld end interface mld_coarse_bld @@ -133,11 +133,11 @@ module mld_c_inner_mod interface mld_aggrmat_asb subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ - use mld_c_prec_type, only : mld_conelev_type + use mld_c_prec_type, only : mld_c_onelev_type type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_conelev_type), intent(inout), target :: p + type(mld_c_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_caggrmat_asb end interface mld_aggrmat_asb @@ -145,11 +145,11 @@ module mld_c_inner_mod interface mld_aggrmat_nosmth_asb subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ - use mld_c_prec_type, only : mld_conelev_type + use mld_c_prec_type, only : mld_c_onelev_type type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_conelev_type), intent(inout), target :: p + type(mld_c_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_caggrmat_nosmth_asb end interface mld_aggrmat_nosmth_asb @@ -157,11 +157,11 @@ module mld_c_inner_mod interface mld_aggrmat_smth_asb subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ - use mld_c_prec_type, only : mld_conelev_type + use mld_c_prec_type, only : mld_c_onelev_type type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_conelev_type), intent(inout), target :: p + type(mld_c_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_caggrmat_smth_asb end interface mld_aggrmat_smth_asb @@ -169,11 +169,11 @@ module mld_c_inner_mod interface mld_aggrmat_minnrg_asb subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ - use mld_c_prec_type, only : mld_conelev_type + use mld_c_prec_type, only : mld_c_onelev_type type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_conelev_type), intent(inout), target :: p + type(mld_c_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_caggrmat_minnrg_asb end interface mld_aggrmat_minnrg_asb diff --git a/mlprec/mld_c_move_alloc_mod.f90 b/mlprec/mld_c_move_alloc_mod.f90 index 53cd92ab..a22635a0 100644 --- a/mlprec/mld_c_move_alloc_mod.f90 +++ b/mlprec/mld_c_move_alloc_mod.f90 @@ -49,16 +49,16 @@ module mld_c_move_alloc_mod use mld_c_prec_type interface mld_move_alloc - module procedure mld_conelev_prec_move_alloc,& + module procedure mld_c_onelev_prec_move_alloc,& & mld_cprec_move_alloc end interface contains - subroutine mld_conelev_prec_move_alloc(a, b,info) + subroutine mld_c_onelev_prec_move_alloc(a, b,info) use psb_base_mod implicit none - type(mld_conelev_type), intent(inout) :: a, b + type(mld_c_onelev_type), intent(inout) :: a, b integer, intent(out) :: info call b%free(info) @@ -69,7 +69,7 @@ contains b%base_a => a%base_a b%base_desc => a%base_desc - end subroutine mld_conelev_prec_move_alloc + end subroutine mld_c_onelev_prec_move_alloc subroutine mld_cprec_move_alloc(a, b,info) use psb_base_mod diff --git a/mlprec/mld_c_onelev_mod.f90 b/mlprec/mld_c_onelev_mod.f90 index fdedab9b..256ebbd3 100644 --- a/mlprec/mld_c_onelev_mod.f90 +++ b/mlprec/mld_c_onelev_mod.f90 @@ -118,7 +118,7 @@ module mld_c_onelev_mod ! get_nzeros - Number of nonzeros ! ! - type mld_conelev_type + type mld_c_onelev_type class(mld_c_base_smoother_type), allocatable :: sm type(mld_sml_parms) :: parms type(psb_cspmat_type) :: ac @@ -139,7 +139,7 @@ module mld_c_onelev_mod generic, public :: set => seti, setr, setc procedure, pass(lv) :: sizeof => c_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => c_base_onelev_get_nzeros - end type mld_conelev_type + end type mld_c_onelev_type private :: c_base_onelev_default, c_base_onelev_sizeof, & & c_base_onelev_nullify, c_base_onelev_get_nzeros @@ -149,10 +149,10 @@ module mld_c_onelev_mod interface mld_c_base_onelev_descr subroutine mld_c_base_onelev_descr(lv,il,nl,info,iout) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & - & psb_clinmap_type, psb_spk_, mld_conelev_type, psb_long_int_k_, psb_desc_type + & psb_clinmap_type, psb_spk_, mld_c_onelev_type, psb_long_int_k_, psb_desc_type Implicit None ! Arguments - class(mld_conelev_type), intent(in) :: lv + class(mld_c_onelev_type), intent(in) :: lv integer, intent(in) :: il,nl integer, intent(out) :: info integer, intent(in), optional :: iout @@ -162,10 +162,10 @@ module mld_c_onelev_mod interface mld_c_base_onelev_free subroutine mld_c_base_onelev_free(lv,info) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & - & psb_clinmap_type, psb_spk_, mld_conelev_type, psb_long_int_k_, psb_desc_type + & psb_clinmap_type, psb_spk_, mld_c_onelev_type, psb_long_int_k_, psb_desc_type implicit none - class(mld_conelev_type), intent(inout) :: lv + class(mld_c_onelev_type), intent(inout) :: lv integer, intent(out) :: info end subroutine mld_c_base_onelev_free end interface mld_c_base_onelev_free @@ -173,10 +173,10 @@ module mld_c_onelev_mod interface mld_c_base_onelev_check subroutine mld_c_base_onelev_check(lv,info) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & - & psb_clinmap_type, psb_spk_, mld_conelev_type, psb_long_int_k_, psb_desc_type + & psb_clinmap_type, psb_spk_, mld_c_onelev_type, psb_long_int_k_, psb_desc_type Implicit None ! Arguments - class(mld_conelev_type), intent(inout) :: lv + class(mld_c_onelev_type), intent(inout) :: lv integer, intent(out) :: info end subroutine mld_c_base_onelev_check end interface mld_c_base_onelev_check @@ -184,11 +184,11 @@ module mld_c_onelev_mod interface mld_c_base_onelev_seti subroutine mld_c_base_onelev_seti(lv,what,val,info) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & - & psb_clinmap_type, psb_spk_, mld_conelev_type, psb_long_int_k_, psb_desc_type + & psb_clinmap_type, psb_spk_, mld_c_onelev_type, psb_long_int_k_, psb_desc_type Implicit None ! Arguments - class(mld_conelev_type), intent(inout) :: lv + class(mld_c_onelev_type), intent(inout) :: lv integer, intent(in) :: what integer, intent(in) :: val integer, intent(out) :: info @@ -198,10 +198,10 @@ module mld_c_onelev_mod interface mld_c_base_onelev_setc subroutine mld_c_base_onelev_setc(lv,what,val,info) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & - & psb_clinmap_type, psb_spk_, mld_conelev_type, psb_long_int_k_, psb_desc_type + & psb_clinmap_type, psb_spk_, mld_c_onelev_type, psb_long_int_k_, psb_desc_type Implicit None ! Arguments - class(mld_conelev_type), intent(inout) :: lv + class(mld_c_onelev_type), intent(inout) :: lv integer, intent(in) :: what character(len=*), intent(in) :: val integer, intent(out) :: info @@ -211,10 +211,10 @@ module mld_c_onelev_mod interface mld_c_base_onelev_setr subroutine mld_c_base_onelev_setr(lv,what,val,info) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & - & psb_clinmap_type, psb_spk_, mld_conelev_type, psb_long_int_k_, psb_desc_type + & psb_clinmap_type, psb_spk_, mld_c_onelev_type, psb_long_int_k_, psb_desc_type Implicit None - class(mld_conelev_type), intent(inout) :: lv + class(mld_c_onelev_type), intent(inout) :: lv integer, intent(in) :: what real(psb_spk_), intent(in) :: val integer, intent(out) :: info @@ -224,9 +224,9 @@ module mld_c_onelev_mod interface mld_c_base_onelev_dump subroutine mld_c_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & - & psb_clinmap_type, psb_spk_, mld_conelev_type, psb_long_int_k_, psb_desc_type + & psb_clinmap_type, psb_spk_, mld_c_onelev_type, psb_long_int_k_, psb_desc_type implicit none - class(mld_conelev_type), intent(in) :: lv + class(mld_c_onelev_type), intent(in) :: lv integer, intent(in) :: level integer, intent(out) :: info character(len=*), intent(in), optional :: prefix, head @@ -243,7 +243,7 @@ contains function c_base_onelev_get_nzeros(lv) result(val) implicit none - class(mld_conelev_type), intent(in) :: lv + class(mld_c_onelev_type), intent(in) :: lv integer(psb_long_int_k_) :: val integer :: i val = 0 @@ -253,7 +253,7 @@ contains function c_base_onelev_sizeof(lv) result(val) implicit none - class(mld_conelev_type), intent(in) :: lv + class(mld_c_onelev_type), intent(in) :: lv integer(psb_long_int_k_) :: val integer :: i @@ -268,7 +268,7 @@ contains subroutine c_base_onelev_nullify(lv) implicit none - class(mld_conelev_type), intent(inout) :: lv + class(mld_c_onelev_type), intent(inout) :: lv nullify(lv%base_a) nullify(lv%base_desc) @@ -290,7 +290,7 @@ contains Implicit None ! Arguments - class(mld_conelev_type), intent(inout) :: lv + class(mld_c_onelev_type), intent(inout) :: lv lv%parms%sweeps = 1 lv%parms%sweeps_pre = 1 diff --git a/mlprec/mld_c_prec_type.f90 b/mlprec/mld_c_prec_type.f90 index 94df1dd0..a6ad8144 100644 --- a/mlprec/mld_c_prec_type.f90 +++ b/mlprec/mld_c_prec_type.f90 @@ -82,7 +82,7 @@ module mld_c_prec_type type, extends(psb_cprec_type) :: mld_cprec_type integer :: ictxt real(psb_spk_) :: op_complexity=szero - type(mld_conelev_type), allocatable :: precv(:) + type(mld_c_onelev_type), allocatable :: precv(:) contains procedure, pass(prec) :: c_apply2_vect => mld_c_apply2_vect procedure, pass(prec) :: c_apply2v => mld_c_apply2v diff --git a/mlprec/mld_d_as_smoother.f90 b/mlprec/mld_d_as_smoother.f90 index 4c145604..b06add65 100644 --- a/mlprec/mld_d_as_smoother.f90 +++ b/mlprec/mld_d_as_smoother.f90 @@ -55,15 +55,15 @@ module mld_d_as_smoother type(psb_desc_type) :: desc_data integer :: novr, restr, prol, nd_nnz_tot contains - procedure, pass(sm) :: check => d_as_smoother_check - procedure, pass(sm) :: dump => d_as_smoother_dmp - procedure, pass(sm) :: build => d_as_smoother_bld - procedure, pass(sm) :: apply_v => d_as_smoother_apply_vect - procedure, pass(sm) :: apply_a => d_as_smoother_apply - procedure, pass(sm) :: free => d_as_smoother_free - procedure, pass(sm) :: seti => d_as_smoother_seti - procedure, pass(sm) :: setc => d_as_smoother_setc - procedure, pass(sm) :: setr => d_as_smoother_setr + procedure, pass(sm) :: check => mld_d_as_smoother_check + procedure, pass(sm) :: dump => mld_d_as_smoother_dmp + procedure, pass(sm) :: build => mld_d_as_smoother_bld + procedure, pass(sm) :: apply_v => mld_d_as_smoother_apply_vect + procedure, pass(sm) :: apply_a => mld_d_as_smoother_apply + 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) :: descr => d_as_smoother_descr procedure, pass(sm) :: sizeof => d_as_smoother_sizeof procedure, pass(sm) :: default => d_as_smoother_default @@ -71,13 +71,8 @@ module mld_d_as_smoother end type mld_d_as_smoother_type - private :: d_as_smoother_bld, d_as_smoother_apply, & - & d_as_smoother_free, d_as_smoother_seti, & - & d_as_smoother_setc, d_as_smoother_setr,& - & d_as_smoother_descr, d_as_smoother_sizeof, & - & d_as_smoother_check, d_as_smoother_default,& - & d_as_smoother_dmp, d_as_smoother_apply_vect,& - & d_as_smoother_get_nzeros + private :: d_as_smoother_descr, d_as_smoother_sizeof, & + & d_as_smoother_default, d_as_smoother_get_nzeros character(len=6), parameter, private :: & & restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/) @@ -85,1284 +80,166 @@ module mld_d_as_smoother & prolong_names(0:3)=(/'none ','sum ','average ','square root'/) + interface mld_d_as_smoother_check + subroutine mld_d_as_smoother_check(sm,info) + import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & + & psb_dpk_, mld_d_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_d_as_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + end subroutine mld_d_as_smoother_check + end interface mld_d_as_smoother_check + + interface mld_d_as_smoother_apply_vect + subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & + & psb_dpk_, mld_d_as_smoother_type, psb_long_int_k_, psb_desc_type + type(psb_desc_type), intent(in) :: desc_data + class(mld_d_as_smoother_type), intent(inout) :: sm + type(psb_d_vect_type),intent(inout) :: x + type(psb_d_vect_type),intent(inout) :: y + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + integer, intent(in) :: sweeps + real(psb_dpk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + end subroutine mld_d_as_smoother_apply_vect + end interface mld_d_as_smoother_apply_vect + + interface mld_d_as_smoother_apply + subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & + & psb_dpk_, mld_d_as_smoother_type, psb_long_int_k_, psb_desc_type + type(psb_desc_type), intent(in) :: desc_data + class(mld_d_as_smoother_type), intent(in) :: sm + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(inout) :: y(:) + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + integer, intent(in) :: sweeps + real(psb_dpk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + end subroutine mld_d_as_smoother_apply + end interface mld_d_as_smoother_apply + + interface mld_d_as_smoother_bld + subroutine mld_d_as_smoother_bld(a,desc_a,sm,upd,info,amold,vmold) + import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & + & psb_dpk_, mld_d_as_smoother_type, psb_long_int_k_, & + & psb_desc_type, psb_d_base_sparse_mat + type(psb_dspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_d_as_smoother_type), intent(inout) :: sm + character, intent(in) :: upd + integer, intent(out) :: info + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + end subroutine mld_d_as_smoother_bld + end interface mld_d_as_smoother_bld + + interface mld_d_as_smoother_seti + subroutine mld_d_as_smoother_seti(sm,what,val,info) + import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & + & psb_dpk_, mld_d_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_d_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + end subroutine mld_d_as_smoother_seti + end interface mld_d_as_smoother_seti + + interface mld_d_as_smoother_setc + subroutine mld_d_as_smoother_setc(sm,what,val,info) + import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & + & psb_dpk_, mld_d_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_d_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + character(len=*), intent(in) :: val + integer, intent(out) :: info + end subroutine mld_d_as_smoother_setc + end interface mld_d_as_smoother_setc + + interface mld_d_as_smoother_setr + subroutine mld_d_as_smoother_setr(sm,what,val,info) + import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & + & psb_dpk_, mld_d_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_d_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer, intent(out) :: info + end subroutine mld_d_as_smoother_setr + end interface mld_d_as_smoother_setr + + interface mld_d_as_smoother_free + subroutine mld_d_as_smoother_free(sm,info) + import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & + & psb_dpk_, mld_d_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_d_as_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + end subroutine mld_d_as_smoother_free + end interface mld_d_as_smoother_free + + interface mld_d_as_smoother_dmp + subroutine mld_d_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) + import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & + & psb_dpk_, mld_d_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_d_as_smoother_type), intent(in) :: sm + integer, intent(in) :: ictxt,level + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: smoother, solver + end subroutine mld_d_as_smoother_dmp + end interface mld_d_as_smoother_dmp + contains - subroutine d_as_smoother_default(sm) - - use psb_base_mod - - Implicit None - - ! Arguments - class(mld_d_as_smoother_type), intent(inout) :: sm - - - sm%restr = psb_halo_ - sm%prol = psb_none_ - sm%novr = 1 - - - if (allocated(sm%sv)) then - call sm%sv%default() - end if - - return - end subroutine d_as_smoother_default - - subroutine d_as_smoother_check(sm,info) - - use psb_base_mod - - Implicit None - + function d_as_smoother_sizeof(sm) result(val) + implicit none ! Arguments - class(mld_d_as_smoother_type), intent(inout) :: sm - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='d_as_smoother_check' - - call psb_erractionsave(err_act) - info = psb_success_ - - call mld_check_def(sm%restr,& - & 'Restrictor',psb_halo_,is_legal_restrict) - call mld_check_def(sm%prol,& - & 'Prolongator',psb_none_,is_legal_prolong) - call mld_check_def(sm%novr,& - & 'Overlap layers ',0,is_legal_n_ovr) - - - if (allocated(sm%sv)) then - call sm%sv%check(info) - else - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - - if (info /= psb_success_) goto 9999 - - 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_as_smoother_check - - subroutine d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - use psb_base_mod - type(psb_desc_type), intent(in) :: desc_data - class(mld_d_as_smoother_type), intent(inout) :: sm - type(psb_d_vect_type),intent(inout) :: x - type(psb_d_vect_type),intent(inout) :: y - real(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans - integer, intent(in) :: sweeps - real(psb_dpk_),target, intent(inout) :: work(:) - integer, intent(out) :: info - - integer :: n_row,n_col, nrow_d, i - real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) - real(psb_dpk_), allocatable :: vx(:) - type(psb_d_vect_type) :: vtx, vty, vww - integer :: ictxt,np,me, err_act,isz,int_err(5) - character :: trans_ - character(len=20) :: name='d_as_smoother_apply', ch_err - - call psb_erractionsave(err_act) - - info = psb_success_ - ictxt = desc_data%get_context() - call psb_info(ictxt,me,np) - - trans_ = psb_toupper(trans) - select case(trans_) - case('N') - case('T') - case('C') - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select - - if (.not.allocated(sm%sv)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - - n_row = sm%desc_data%get_local_rows() - n_col = sm%desc_data%get_local_cols() - nrow_d = desc_data%get_local_rows() - isz = max(n_row,N_COL) - - if ((6*isz) <= size(work)) then - ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) - aux => work(3*isz+1:) - else if ((4*isz) <= size(work)) then - aux => work(1:) - allocate(ww(isz),tx(isz),ty(isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),& - & a_err='real(psb_dpk_)') - goto 9999 - end if - else if ((3*isz) <= size(work)) then - ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) - allocate(aux(4*isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& - & a_err='real(psb_dpk_)') - goto 9999 - end if - else - allocate(ww(isz),tx(isz),ty(isz),& - &aux(4*isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& - & a_err='real(psb_dpk_)') - goto 9999 - end if - - endif - - if ((sm%novr == 0).and.(sweeps == 1)) then - ! - ! Shortcut: in this case it's just the same - ! as Block Jacobi. - ! - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') - goto 9999 - endif - - else - - - vx = x%get_vect() - - call psb_geall(vtx,sm%desc_data,info) - call psb_geasb(vtx,sm%desc_data,info,mold=x%v) - call psb_geall(vty,sm%desc_data,info) - call psb_geasb(vty,sm%desc_data,info,mold=x%v) - call psb_geall(vww,sm%desc_data,info) - call psb_geasb(vww,sm%desc_data,info,mold=x%v) - call vtx%set(dzero) - call vty%set(dzero) - call vww%set(dzero) - - - call vtx%set(vx(1:nrow_d)) - - if (sweeps == 1) then - - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (sm%restr == psb_halo_) then - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - - case('T','C') - ! - ! With transpose, we have to do it here - ! - - select case (sm%prol) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case(psb_avg_) - ! - ! Tricky one: first we have to scale the overlap entries, - ! which we can do by assignind mode=0, i.e. no communication - ! (hence only scaling), then we do the halo - ! - call psb_ovrl(vtx,sm%desc_data,info,& - & update=psb_avg_,work=aux,mode=0) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - call sm%sv%apply(done,vtx,dzero,vty,sm%desc_data,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') - goto 9999 - endif - - select case(trans_) - case('N') - - select case (sm%prol) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,sm%desc_data,info,& - ! & update=sm%prol,work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(vty,sm%desc_data,info,& - & update=sm%prol,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - case('T','C') - ! - ! With transpose, we have to do it here - ! - if (sm%restr == psb_halo_) then - call psb_ovrl(vty,sm%desc_data,info,& - & update=psb_sum_,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - - - else if (sweeps > 1) then - - ! - ! - ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver - ! to compute an approximate solution of a linear system. - ! - ! - call vty%set(dzero) - - do i=1, sweeps - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (sm%restr == psb_halo_) then - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - - case('T','C') - ! - ! With transpose, we have to do it here - ! - - select case (sm%prol) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case(psb_avg_) - ! - ! Tricky one: first we have to scale the overlap entries, - ! which we can do by assignind mode=0, i.e. no communication - ! (hence only scaling), then we do the halo - ! - call psb_ovrl(vtx,sm%desc_data,info,& - & update=psb_avg_,work=aux,mode=0) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - ! - ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the - ! block diagonal part and the remaining part of the local matrix - ! and Y(j) is the approximate solution at sweep j. - ! - call psb_geaxpby(done,vtx,dzero,vww,sm%desc_data,info) - call psb_spmm(-done,sm%nd,vty,done,vww,sm%desc_data,info,& - & work=aux,trans=trans_) - - if (info /= psb_success_) exit - - call sm%sv%apply(done,vww,dzero,vty,sm%desc_data,trans_,aux,info) - - if (info /= psb_success_) exit - - - select case(trans_) - case('N') - - select case (sm%prol) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,sm%desc_data,info,& - ! & update=sm%prol,work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(vty,sm%desc_data,info,& - & update=sm%prol,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - case('T','C') - ! - ! With transpose, we have to do it here - ! - if (sm%restr == psb_halo_) then - call psb_ovrl(vty,sm%desc_data,info,& - & update=psb_sum_,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - end do - - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 - end if - - - else - - info = psb_err_iarg_neg_ - call psb_errpush(info,name,& - & i_err=(/2,sweeps,0,0,0/)) - goto 9999 - - - end if - - ! - ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) - ! - call psb_geaxpby(alpha,vty,beta,y,desc_data,info) - - end if - - - if ((6*isz) <= size(work)) then - else if ((4*isz) <= size(work)) then - deallocate(ww,tx,ty) - else if ((3*isz) <= size(work)) then - deallocate(aux) - else - deallocate(ww,aux,tx,ty) - endif - call vww%free(info) - call vtx%free(info) - call vty%free(info) - - 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_as_smoother_apply_vect - - - subroutine d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - use psb_base_mod - type(psb_desc_type), intent(in) :: desc_data class(mld_d_as_smoother_type), intent(in) :: sm - real(psb_dpk_),intent(inout) :: x(:) - real(psb_dpk_),intent(inout) :: y(:) - real(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans - integer, intent(in) :: sweeps - real(psb_dpk_),target, intent(inout) :: work(:) - integer, intent(out) :: info - - integer :: n_row,n_col, nrow_d, i - real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) - integer :: ictxt,np,me, err_act,isz,int_err(5) - character :: trans_ - character(len=20) :: name='d_as_smoother_apply', ch_err - - call psb_erractionsave(err_act) - - info = psb_success_ - ictxt = desc_data%get_context() - call psb_info (ictxt,me,np) - - trans_ = psb_toupper(trans) - select case(trans_) - case('N') - case('T') - case('C') - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select - - if (.not.allocated(sm%sv)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - - n_row = sm%desc_data%get_local_rows() - n_col = sm%desc_data%get_local_cols() - nrow_d = desc_data%get_local_rows() - isz=max(n_row,N_COL) - if ((6*isz) <= size(work)) then - ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) - aux => work(3*isz+1:) - else if ((4*isz) <= size(work)) then - aux => work(1:) - allocate(ww(isz),tx(isz),ty(isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),& - & a_err='real(psb_dpk_)') - goto 9999 - end if - else if ((3*isz) <= size(work)) then - ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) - allocate(aux(4*isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& - & a_err='real(psb_dpk_)') - goto 9999 - end if - else - allocate(ww(isz),tx(isz),ty(isz),& - &aux(4*isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& - & a_err='real(psb_dpk_)') - goto 9999 - end if - - endif - - if ((sm%novr == 0).and.(sweeps == 1)) then - ! - ! Shortcut: in this case it's just the same - ! as Block Jacobi. - ! - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') - goto 9999 - endif - - else - - - tx(1:nrow_d) = x(1:nrow_d) - tx(nrow_d+1:isz) = dzero - - - if (sweeps == 1) then - - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (sm%restr == psb_halo_) then - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - - case('T','C') - ! - ! With transpose, we have to do it here - ! - - select case (sm%prol) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case(psb_avg_) - ! - ! Tricky one: first we have to scale the overlap entries, - ! which we can do by assignind mode=0, i.e. no communication - ! (hence only scaling), then we do the halo - ! - call psb_ovrl(tx,sm%desc_data,info,& - & update=psb_avg_,work=aux,mode=0) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - call sm%sv%apply(done,tx,dzero,ty,sm%desc_data,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') - goto 9999 - endif - - select case(trans_) - case('N') - - select case (sm%prol) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,sm%desc_data,info,& - ! & update=sm%prol,work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(ty,sm%desc_data,info,& - & update=sm%prol,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - case('T','C') - ! - ! With transpose, we have to do it here - ! - if (sm%restr == psb_halo_) then - call psb_ovrl(ty,sm%desc_data,info,& - & update=psb_sum_,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - - - else if (sweeps > 1) then - - ! - ! - ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver - ! to compute an approximate solution of a linear system. - ! - ! - ty = dzero - do i=1, sweeps - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (sm%restr == psb_halo_) then - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - - case('T','C') - ! - ! With transpose, we have to do it here - ! - - select case (sm%prol) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case(psb_avg_) - ! - ! Tricky one: first we have to scale the overlap entries, - ! which we can do by assignind mode=0, i.e. no communication - ! (hence only scaling), then we do the halo - ! - call psb_ovrl(tx,sm%desc_data,info,& - & update=psb_avg_,work=aux,mode=0) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - ! - ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the - ! block diagonal part and the remaining part of the local matrix - ! and Y(j) is the approximate solution at sweep j. - ! - ww(1:n_row) = tx(1:n_row) - call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,work=aux,trans=trans_) - - if (info /= psb_success_) exit - - call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info) - - if (info /= psb_success_) exit - - - select case(trans_) - case('N') - - select case (sm%prol) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,sm%desc_data,info,& - ! & update=sm%prol,work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(ty,sm%desc_data,info,& - & update=sm%prol,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - case('T','C') - ! - ! With transpose, we have to do it here - ! - if (sm%restr == psb_halo_) then - call psb_ovrl(ty,sm%desc_data,info,& - & update=psb_sum_,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - end do - - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1') - goto 9999 - end if - - - else - - info = psb_err_iarg_neg_ - call psb_errpush(info,name,& - & i_err=(/2,sweeps,0,0,0/)) - goto 9999 - - - end if - - ! - ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) - ! - call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - - end if - - - if ((6*isz) <= size(work)) then - else if ((4*isz) <= size(work)) then - deallocate(ww,tx,ty) - else if ((3*isz) <= size(work)) then - deallocate(aux) - else - deallocate(ww,aux,tx,ty) - endif - - 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_as_smoother_apply - - subroutine d_as_smoother_bld(a,desc_a,sm,upd,info,amold,vmold) - - use psb_base_mod - - Implicit None - - ! Arguments - type(psb_dspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(in) :: desc_a - class(mld_d_as_smoother_type), intent(inout) :: sm - character, intent(in) :: upd - integer, intent(out) :: info - class(psb_d_base_sparse_mat), intent(in), optional :: amold - class(psb_d_base_vect_type), intent(in), optional :: vmold - - ! Local variables - type(psb_dspmat_type) :: blck, atmp - integer :: n_row,n_col, nrow_a, nhalo, novr, data_, nzeros - real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) - integer :: ictxt,np,me,i, err_act, debug_unit, debug_level - character(len=20) :: name='d_as_smoother_bld', ch_err - - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),' start' - - - novr = sm%novr - if (novr < 0) then - info=psb_err_invalid_ovr_num_ - call psb_errpush(info,name,i_err=(/novr,0,0,0,0,0/)) - goto 9999 - endif - - if ((novr == 0).or.(np == 1)) then - if (psb_toupper(upd) == 'F') then - call psb_cdcpy(desc_a,sm%desc_data,info) - If(debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' done cdcpy' - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_cdcpy' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Early return: P>=3 N_OVR=0' - endif - call blck%csall(0,0,info,1) - else - - If (psb_toupper(upd) == 'F') Then - ! - ! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_). - ! This is done by psb_cdbldext (interface to psb_cdovr), which is - ! independent of CSR, and has been placed in the tools directory - ! of PSBLAS, instead of the mlprec directory of MLD2P4, because it - ! might be used independently of the AS preconditioner, to build - ! a descriptor for an extended stencil in a PDE solver. - ! - call psb_cdbldext(a,desc_a,novr,sm%desc_data,info,extype=psb_ovt_asov_) - if(debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' From cdbldext _:',sm%desc_data%get_local_rows(),& - & sm%desc_data%get_local_cols() - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_cdbldext' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - Endif - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Before sphalo ' - - ! - ! Retrieve the remote sparse matrix rows required for the AS extended - ! matrix - data_ = psb_comm_ext_ - Call psb_sphalo(a,sm%desc_data,blck,info,data=data_,rowscale=.true.) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sphalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if (debug_level >=psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'After psb_sphalo ',& - & blck%get_nrows(), blck%get_nzeros() - - End if - if (info == psb_success_) & - & call sm%sv%build(a,sm%desc_data,upd,info,& - & blck,amold=amold,vmold=vmold) - - nrow_a = a%get_nrows() - n_row = sm%desc_data%get_local_rows() - n_col = sm%desc_data%get_local_cols() - - if (info == psb_success_) call a%csclip(sm%nd,info,& - & jmin=nrow_a+1,rscale=.false.,cscale=.false.) - if (info == psb_success_) call blck%csclip(atmp,info,& - & jmin=nrow_a+1,rscale=.false.,cscale=.false.) - if (info == psb_success_) call psb_rwextd(n_row,sm%nd,info,b=atmp) - - if (info == psb_success_) then - if (present(amold)) then - call sm%nd%cscnv(info,& - & mold=amold,dupl=psb_dupl_add_) - else - call sm%nd%cscnv(info,& - & type='csr',dupl=psb_dupl_add_) - end if - end if - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4') - goto 9999 - end if - nzeros = sm%nd%get_nzeros() -!!$ write(0,*) me,' ND nzeors ',nzeros - call psb_sum(ictxt,nzeros) - sm%nd_nnz_tot = nzeros - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),' end' - - 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_as_smoother_bld - - - subroutine d_as_smoother_seti(sm,what,val,info) - - use psb_base_mod - - Implicit None - - ! Arguments - class(mld_d_as_smoother_type), intent(inout) :: sm - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='d_as_smoother_seti' - - info = psb_success_ - 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_) - sm%restr = val - case(mld_sub_prol_) - sm%prol = val - case default - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if - end select + integer(psb_long_int_k_) :: val + integer :: i - call psb_erractionrestore(err_act) - return + val = psb_sizeof_int + if (allocated(sm%sv)) val = val + sm%sv%sizeof() + val = val + sm%nd%sizeof() -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return - end subroutine d_as_smoother_seti - - subroutine d_as_smoother_setc(sm,what,val,info) - - use psb_base_mod - - Implicit None - - ! Arguments - class(mld_d_as_smoother_type), intent(inout) :: sm - integer, intent(in) :: what - character(len=*), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, ival - character(len=20) :: name='d_as_smoother_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - - call mld_stringval(val,ival,info) - if (info == psb_success_) call sm%set(what,ival,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info, name) - goto 9999 - end if + end function d_as_smoother_sizeof - call psb_erractionrestore(err_act) - return + function d_as_smoother_get_nzeros(sm) result(val) + implicit none + class(mld_d_as_smoother_type), intent(in) :: sm + integer(psb_long_int_k_) :: val + integer :: i + val = 0 + if (allocated(sm%sv)) & + & val = sm%sv%get_nzeros() + val = val + sm%nd%get_nzeros() -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_as_smoother_setc + end function d_as_smoother_get_nzeros - subroutine d_as_smoother_setr(sm,what,val,info) + subroutine d_as_smoother_default(sm) - use psb_base_mod + use psb_base_mod, only : psb_halo_, psb_none_ Implicit None ! Arguments class(mld_d_as_smoother_type), intent(inout) :: sm - integer, intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='d_as_smoother_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - else -!!$ write(0,*) trim(name),' Missing component, not setting!' -!!$ info = 1121 - 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_as_smoother_setr - - subroutine d_as_smoother_free(sm,info) - - use psb_base_mod - - Implicit None - - ! Arguments - class(mld_d_as_smoother_type), intent(inout) :: sm - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='d_as_smoother_free' - - call psb_erractionsave(err_act) - info = psb_success_ + sm%restr = psb_halo_ + sm%prol = psb_none_ + sm%novr = 1 if (allocated(sm%sv)) then - call sm%sv%free(info) - if (info == psb_success_) deallocate(sm%sv,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + call sm%sv%default() end if - call sm%nd%free() - call psb_erractionrestore(err_act) return + end subroutine d_as_smoother_default -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine d_as_smoother_free subroutine d_as_smoother_descr(sm,info,iout,coarse) @@ -1419,77 +296,4 @@ contains return end subroutine d_as_smoother_descr - function d_as_smoother_sizeof(sm) result(val) - use psb_base_mod - implicit none - ! Arguments - class(mld_d_as_smoother_type), intent(in) :: sm - integer(psb_long_int_k_) :: val - integer :: i - - val = psb_sizeof_int - if (allocated(sm%sv)) val = val + sm%sv%sizeof() - val = val + sm%nd%sizeof() - - return - end function d_as_smoother_sizeof - - function d_as_smoother_get_nzeros(sm) result(val) - implicit none - class(mld_d_as_smoother_type), intent(in) :: sm - integer(psb_long_int_k_) :: val - integer :: i - val = 0 - if (allocated(sm%sv)) & - & val = sm%sv%get_nzeros() - val = val + sm%nd%get_nzeros() - - end function d_as_smoother_get_nzeros - - subroutine d_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) - use psb_base_mod - implicit none - class(mld_d_as_smoother_type), intent(in) :: sm - integer, intent(in) :: ictxt,level - integer, intent(out) :: info - character(len=*), intent(in), optional :: prefix, head - logical, optional, intent(in) :: smoother, solver - integer :: i, j, il1, iln, lname, lev - integer :: icontxt,iam, np - character(len=80) :: prefix_ - character(len=120) :: fname ! len should be at least 20 more than - logical :: smoother_ - ! len of prefix_ - - info = 0 - - if (present(prefix)) then - prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) - else - prefix_ = "dump_smth_d" - end if - - call psb_info(ictxt,iam,np) - - if (present(smoother)) then - smoother_ = smoother - else - smoother_ = .false. - end if - lname = len_trim(prefix_) - fname = trim(prefix_) - write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam - lname = lname + 5 - - if (smoother_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx' - if (sm%nd%is_asb()) & - & call sm%nd%print(fname,head=head) - end if - ! At base level do nothing for the smoother - if (allocated(sm%sv)) & - & call sm%sv%dump(ictxt,level,info,solver=solver) - - end subroutine d_as_smoother_dmp - end module mld_d_as_smoother diff --git a/mlprec/mld_d_inner_mod.f90 b/mlprec/mld_d_inner_mod.f90 index 5732cf73..dd544385 100644 --- a/mlprec/mld_d_inner_mod.f90 +++ b/mlprec/mld_d_inner_mod.f90 @@ -98,10 +98,10 @@ module mld_d_inner_mod interface mld_coarse_bld subroutine mld_dcoarse_bld(a,desc_a,p,info) use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ - use mld_d_prec_type, only : mld_donelev_type + use mld_d_prec_type, only : mld_d_onelev_type type(psb_dspmat_type), intent(in), target :: a type(psb_desc_type), intent(in), target :: desc_a - type(mld_donelev_type), intent(inout), target :: p + type(mld_d_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_dcoarse_bld end interface mld_coarse_bld @@ -133,11 +133,11 @@ module mld_d_inner_mod interface mld_aggrmat_asb subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ - use mld_d_prec_type, only : mld_donelev_type + use mld_d_prec_type, only : mld_d_onelev_type type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_donelev_type), intent(inout), target :: p + type(mld_d_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_daggrmat_asb end interface mld_aggrmat_asb @@ -145,11 +145,11 @@ module mld_d_inner_mod interface mld_aggrmat_nosmth_asb subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ - use mld_d_prec_type, only : mld_donelev_type + use mld_d_prec_type, only : mld_d_onelev_type type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_donelev_type), intent(inout), target :: p + type(mld_d_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_daggrmat_nosmth_asb end interface mld_aggrmat_nosmth_asb @@ -157,11 +157,11 @@ module mld_d_inner_mod interface mld_aggrmat_smth_asb subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ - use mld_d_prec_type, only : mld_donelev_type + use mld_d_prec_type, only : mld_d_onelev_type type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_donelev_type), intent(inout), target :: p + type(mld_d_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_daggrmat_smth_asb end interface mld_aggrmat_smth_asb @@ -169,11 +169,11 @@ module mld_d_inner_mod interface mld_aggrmat_minnrg_asb subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ - use mld_d_prec_type, only : mld_donelev_type + use mld_d_prec_type, only : mld_d_onelev_type type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_donelev_type), intent(inout), target :: p + type(mld_d_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_daggrmat_minnrg_asb end interface mld_aggrmat_minnrg_asb diff --git a/mlprec/mld_d_move_alloc_mod.f90 b/mlprec/mld_d_move_alloc_mod.f90 index 35256292..f9e0ea33 100644 --- a/mlprec/mld_d_move_alloc_mod.f90 +++ b/mlprec/mld_d_move_alloc_mod.f90 @@ -49,16 +49,16 @@ module mld_d_move_alloc_mod use mld_d_prec_type interface mld_move_alloc - module procedure mld_donelev_prec_move_alloc,& + module procedure mld_d_onelev_prec_move_alloc,& & mld_dprec_move_alloc end interface contains - subroutine mld_donelev_prec_move_alloc(a, b,info) + subroutine mld_d_onelev_prec_move_alloc(a, b,info) use psb_base_mod implicit none - type(mld_donelev_type), intent(inout) :: a, b + type(mld_d_onelev_type), intent(inout) :: a, b integer, intent(out) :: info call b%free(info) @@ -69,7 +69,7 @@ contains b%base_a => a%base_a b%base_desc => a%base_desc - end subroutine mld_donelev_prec_move_alloc + end subroutine mld_d_onelev_prec_move_alloc subroutine mld_dprec_move_alloc(a, b,info) use psb_base_mod diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index 6e5ec3c6..a1ef9fad 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -118,7 +118,7 @@ module mld_d_onelev_mod ! get_nzeros - Number of nonzeros ! ! - type mld_donelev_type + type mld_d_onelev_type class(mld_d_base_smoother_type), allocatable :: sm type(mld_dml_parms) :: parms type(psb_dspmat_type) :: ac @@ -139,7 +139,7 @@ module mld_d_onelev_mod generic, public :: set => seti, setr, setc procedure, pass(lv) :: sizeof => d_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros - end type mld_donelev_type + end type mld_d_onelev_type private :: d_base_onelev_default, d_base_onelev_sizeof, & & d_base_onelev_nullify, d_base_onelev_get_nzeros @@ -149,10 +149,10 @@ module mld_d_onelev_mod interface mld_d_base_onelev_descr subroutine mld_d_base_onelev_descr(lv,il,nl,info,iout) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & - & psb_dlinmap_type, psb_dpk_, mld_donelev_type, psb_long_int_k_, psb_desc_type + & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, psb_long_int_k_, psb_desc_type Implicit None ! Arguments - class(mld_donelev_type), intent(in) :: lv + class(mld_d_onelev_type), intent(in) :: lv integer, intent(in) :: il,nl integer, intent(out) :: info integer, intent(in), optional :: iout @@ -162,10 +162,10 @@ module mld_d_onelev_mod interface mld_d_base_onelev_free subroutine mld_d_base_onelev_free(lv,info) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & - & psb_dlinmap_type, psb_dpk_, mld_donelev_type, psb_long_int_k_, psb_desc_type + & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, psb_long_int_k_, psb_desc_type implicit none - class(mld_donelev_type), intent(inout) :: lv + class(mld_d_onelev_type), intent(inout) :: lv integer, intent(out) :: info end subroutine mld_d_base_onelev_free end interface mld_d_base_onelev_free @@ -173,10 +173,10 @@ module mld_d_onelev_mod interface mld_d_base_onelev_check subroutine mld_d_base_onelev_check(lv,info) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & - & psb_dlinmap_type, psb_dpk_, mld_donelev_type, psb_long_int_k_, psb_desc_type + & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, psb_long_int_k_, psb_desc_type Implicit None ! Arguments - class(mld_donelev_type), intent(inout) :: lv + class(mld_d_onelev_type), intent(inout) :: lv integer, intent(out) :: info end subroutine mld_d_base_onelev_check end interface mld_d_base_onelev_check @@ -184,11 +184,11 @@ module mld_d_onelev_mod interface mld_d_base_onelev_seti subroutine mld_d_base_onelev_seti(lv,what,val,info) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & - & psb_dlinmap_type, psb_dpk_, mld_donelev_type, psb_long_int_k_, psb_desc_type + & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, psb_long_int_k_, psb_desc_type Implicit None ! Arguments - class(mld_donelev_type), intent(inout) :: lv + class(mld_d_onelev_type), intent(inout) :: lv integer, intent(in) :: what integer, intent(in) :: val integer, intent(out) :: info @@ -198,10 +198,10 @@ module mld_d_onelev_mod interface mld_d_base_onelev_setc subroutine mld_d_base_onelev_setc(lv,what,val,info) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & - & psb_dlinmap_type, psb_dpk_, mld_donelev_type, psb_long_int_k_, psb_desc_type + & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, psb_long_int_k_, psb_desc_type Implicit None ! Arguments - class(mld_donelev_type), intent(inout) :: lv + class(mld_d_onelev_type), intent(inout) :: lv integer, intent(in) :: what character(len=*), intent(in) :: val integer, intent(out) :: info @@ -211,10 +211,10 @@ module mld_d_onelev_mod interface mld_d_base_onelev_setr subroutine mld_d_base_onelev_setr(lv,what,val,info) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & - & psb_dlinmap_type, psb_dpk_, mld_donelev_type, psb_long_int_k_, psb_desc_type + & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, psb_long_int_k_, psb_desc_type Implicit None - class(mld_donelev_type), intent(inout) :: lv + class(mld_d_onelev_type), intent(inout) :: lv integer, intent(in) :: what real(psb_dpk_), intent(in) :: val integer, intent(out) :: info @@ -224,9 +224,9 @@ module mld_d_onelev_mod interface mld_d_base_onelev_dump subroutine mld_d_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & - & psb_dlinmap_type, psb_dpk_, mld_donelev_type, psb_long_int_k_, psb_desc_type + & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, psb_long_int_k_, psb_desc_type implicit none - class(mld_donelev_type), intent(in) :: lv + class(mld_d_onelev_type), intent(in) :: lv integer, intent(in) :: level integer, intent(out) :: info character(len=*), intent(in), optional :: prefix, head @@ -243,7 +243,7 @@ contains function d_base_onelev_get_nzeros(lv) result(val) implicit none - class(mld_donelev_type), intent(in) :: lv + class(mld_d_onelev_type), intent(in) :: lv integer(psb_long_int_k_) :: val integer :: i val = 0 @@ -253,7 +253,7 @@ contains function d_base_onelev_sizeof(lv) result(val) implicit none - class(mld_donelev_type), intent(in) :: lv + class(mld_d_onelev_type), intent(in) :: lv integer(psb_long_int_k_) :: val integer :: i @@ -268,7 +268,7 @@ contains subroutine d_base_onelev_nullify(lv) implicit none - class(mld_donelev_type), intent(inout) :: lv + class(mld_d_onelev_type), intent(inout) :: lv nullify(lv%base_a) nullify(lv%base_desc) @@ -290,7 +290,7 @@ contains Implicit None ! Arguments - class(mld_donelev_type), intent(inout) :: lv + class(mld_d_onelev_type), intent(inout) :: lv lv%parms%sweeps = 1 lv%parms%sweeps_pre = 1 diff --git a/mlprec/mld_d_prec_type.f90 b/mlprec/mld_d_prec_type.f90 index 0897fc91..2c05be91 100644 --- a/mlprec/mld_d_prec_type.f90 +++ b/mlprec/mld_d_prec_type.f90 @@ -82,7 +82,7 @@ module mld_d_prec_type type, extends(psb_dprec_type) :: mld_dprec_type integer :: ictxt real(psb_dpk_) :: op_complexity=dzero - type(mld_donelev_type), allocatable :: precv(:) + type(mld_d_onelev_type), allocatable :: precv(:) contains procedure, pass(prec) :: d_apply2_vect => mld_d_apply2_vect procedure, pass(prec) :: d_apply2v => mld_d_apply2v diff --git a/mlprec/mld_s_as_smoother.f90 b/mlprec/mld_s_as_smoother.f90 index 286b050d..7bbe3310 100644 --- a/mlprec/mld_s_as_smoother.f90 +++ b/mlprec/mld_s_as_smoother.f90 @@ -44,7 +44,7 @@ ! module mld_s_as_smoother - use mld_s_base_smoother_mod + use mld_s_base_smoother_mod type, extends(mld_s_base_smoother_type) :: mld_s_as_smoother_type ! The local solver component is inherited from the @@ -55,15 +55,15 @@ module mld_s_as_smoother type(psb_desc_type) :: desc_data integer :: novr, restr, prol, nd_nnz_tot contains - procedure, pass(sm) :: check => s_as_smoother_check - procedure, pass(sm) :: dump => s_as_smoother_dmp - procedure, pass(sm) :: build => s_as_smoother_bld - procedure, pass(sm) :: apply_v => s_as_smoother_apply_vect - procedure, pass(sm) :: apply_a => s_as_smoother_apply - procedure, pass(sm) :: free => s_as_smoother_free - procedure, pass(sm) :: seti => s_as_smoother_seti - procedure, pass(sm) :: setc => s_as_smoother_setc - procedure, pass(sm) :: setr => s_as_smoother_setr + procedure, pass(sm) :: check => mld_s_as_smoother_check + procedure, pass(sm) :: dump => mld_s_as_smoother_dmp + procedure, pass(sm) :: build => mld_s_as_smoother_bld + procedure, pass(sm) :: apply_v => mld_s_as_smoother_apply_vect + procedure, pass(sm) :: apply_a => mld_s_as_smoother_apply + 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) :: descr => s_as_smoother_descr procedure, pass(sm) :: sizeof => s_as_smoother_sizeof procedure, pass(sm) :: default => s_as_smoother_default @@ -71,13 +71,8 @@ module mld_s_as_smoother end type mld_s_as_smoother_type - private :: s_as_smoother_bld, s_as_smoother_apply, & - & s_as_smoother_free, s_as_smoother_seti, & - & s_as_smoother_setc, s_as_smoother_setr,& - & s_as_smoother_descr, s_as_smoother_sizeof, & - & s_as_smoother_check, s_as_smoother_default,& - & s_as_smoother_dmp, s_as_smoother_apply_vect,& - & s_as_smoother_get_nzeros + private :: s_as_smoother_descr, s_as_smoother_sizeof, & + & s_as_smoother_default, s_as_smoother_get_nzeros character(len=6), parameter, private :: & & restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/) @@ -85,1284 +80,166 @@ module mld_s_as_smoother & prolong_names(0:3)=(/'none ','sum ','average ','square root'/) + interface mld_s_as_smoother_check + subroutine mld_s_as_smoother_check(sm,info) + import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & + & psb_spk_, mld_s_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_s_as_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + end subroutine mld_s_as_smoother_check + end interface mld_s_as_smoother_check + + interface mld_s_as_smoother_apply_vect + subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & + & psb_spk_, mld_s_as_smoother_type, psb_long_int_k_, psb_desc_type + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_as_smoother_type), intent(inout) :: sm + type(psb_s_vect_type),intent(inout) :: x + type(psb_s_vect_type),intent(inout) :: y + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + integer, intent(in) :: sweeps + real(psb_spk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + end subroutine mld_s_as_smoother_apply_vect + end interface mld_s_as_smoother_apply_vect + + interface mld_s_as_smoother_apply + subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & + & psb_spk_, mld_s_as_smoother_type, psb_long_int_k_, psb_desc_type + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_as_smoother_type), intent(in) :: sm + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + integer, intent(in) :: sweeps + real(psb_spk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + end subroutine mld_s_as_smoother_apply + end interface mld_s_as_smoother_apply + + interface mld_s_as_smoother_bld + subroutine mld_s_as_smoother_bld(a,desc_a,sm,upd,info,amold,vmold) + import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & + & psb_spk_, mld_s_as_smoother_type, psb_long_int_k_, & + & psb_desc_type, psb_s_base_sparse_mat + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_s_as_smoother_type), intent(inout) :: sm + character, intent(in) :: upd + integer, intent(out) :: info + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + end subroutine mld_s_as_smoother_bld + end interface mld_s_as_smoother_bld + + interface mld_s_as_smoother_seti + subroutine mld_s_as_smoother_seti(sm,what,val,info) + import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & + & psb_spk_, mld_s_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_s_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + end subroutine mld_s_as_smoother_seti + end interface mld_s_as_smoother_seti + + interface mld_s_as_smoother_setc + subroutine mld_s_as_smoother_setc(sm,what,val,info) + import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & + & psb_spk_, mld_s_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_s_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + character(len=*), intent(in) :: val + integer, intent(out) :: info + end subroutine mld_s_as_smoother_setc + end interface mld_s_as_smoother_setc + + interface mld_s_as_smoother_setr + subroutine mld_s_as_smoother_setr(sm,what,val,info) + import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & + & psb_spk_, mld_s_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_s_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + end subroutine mld_s_as_smoother_setr + end interface mld_s_as_smoother_setr + + interface mld_s_as_smoother_free + subroutine mld_s_as_smoother_free(sm,info) + import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & + & psb_spk_, mld_s_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_s_as_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + end subroutine mld_s_as_smoother_free + end interface mld_s_as_smoother_free + + interface mld_s_as_smoother_dmp + subroutine mld_s_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) + import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & + & psb_spk_, mld_s_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_s_as_smoother_type), intent(in) :: sm + integer, intent(in) :: ictxt,level + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: smoother, solver + end subroutine mld_s_as_smoother_dmp + end interface mld_s_as_smoother_dmp + contains - subroutine s_as_smoother_default(sm) - - use psb_base_mod - - Implicit None - - ! Arguments - class(mld_s_as_smoother_type), intent(inout) :: sm - - - sm%restr = psb_halo_ - sm%prol = psb_none_ - sm%novr = 1 - - - if (allocated(sm%sv)) then - call sm%sv%default() - end if - - return - end subroutine s_as_smoother_default - - subroutine s_as_smoother_check(sm,info) - - use psb_base_mod - - Implicit None - + function s_as_smoother_sizeof(sm) result(val) + implicit none ! Arguments - class(mld_s_as_smoother_type), intent(inout) :: sm - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='s_as_smoother_check' - - call psb_erractionsave(err_act) - info = psb_success_ - - call mld_check_def(sm%restr,& - & 'Restrictor',psb_halo_,is_legal_restrict) - call mld_check_def(sm%prol,& - & 'Prolongator',psb_none_,is_legal_prolong) - call mld_check_def(sm%novr,& - & 'Overlap layers ',0,is_legal_n_ovr) - - - if (allocated(sm%sv)) then - call sm%sv%check(info) - else - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - - if (info /= psb_success_) goto 9999 - - 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_as_smoother_check - - subroutine s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - use psb_base_mod - type(psb_desc_type), intent(in) :: desc_data - class(mld_s_as_smoother_type), intent(inout) :: sm - type(psb_s_vect_type),intent(inout) :: x - type(psb_s_vect_type),intent(inout) :: y - real(psb_spk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans - integer, intent(in) :: sweeps - real(psb_spk_),target, intent(inout) :: work(:) - integer, intent(out) :: info - - integer :: n_row,n_col, nrow_d, i - real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) - real(psb_spk_), allocatable :: vx(:) - type(psb_s_vect_type) :: vtx, vty, vww - integer :: ictxt,np,me, err_act,isz,int_err(5) - character :: trans_ - character(len=20) :: name='s_as_smoother_apply', ch_err - - call psb_erractionsave(err_act) - - info = psb_success_ - ictxt = desc_data%get_context() - call psb_info(ictxt,me,np) - - trans_ = psb_toupper(trans) - select case(trans_) - case('N') - case('T') - case('C') - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select - - if (.not.allocated(sm%sv)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - - n_row = sm%desc_data%get_local_rows() - n_col = sm%desc_data%get_local_cols() - nrow_d = desc_data%get_local_rows() - isz = max(n_row,N_COL) - - if ((6*isz) <= size(work)) then - ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) - aux => work(3*isz+1:) - else if ((4*isz) <= size(work)) then - aux => work(1:) - allocate(ww(isz),tx(isz),ty(isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),& - & a_err='real(psb_spk_)') - goto 9999 - end if - else if ((3*isz) <= size(work)) then - ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) - allocate(aux(4*isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& - & a_err='real(psb_spk_)') - goto 9999 - end if - else - allocate(ww(isz),tx(isz),ty(isz),& - &aux(4*isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& - & a_err='real(psb_spk_)') - goto 9999 - end if - - endif - - if ((sm%novr == 0).and.(sweeps == 1)) then - ! - ! Shortcut: in this case it's just the same - ! as Block Jacobi. - ! - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') - goto 9999 - endif - - else - - - vx = x%get_vect() - - call psb_geall(vtx,sm%desc_data,info) - call psb_geasb(vtx,sm%desc_data,info,mold=x%v) - call psb_geall(vty,sm%desc_data,info) - call psb_geasb(vty,sm%desc_data,info,mold=x%v) - call psb_geall(vww,sm%desc_data,info) - call psb_geasb(vww,sm%desc_data,info,mold=x%v) - call vtx%set(szero) - call vty%set(szero) - call vww%set(szero) - - - call vtx%set(vx(1:nrow_d)) - - if (sweeps == 1) then - - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (sm%restr == psb_halo_) then - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - - case('T','C') - ! - ! With transpose, we have to do it here - ! - - select case (sm%prol) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case(psb_avg_) - ! - ! Tricky one: first we have to scale the overlap entries, - ! which we can do by assignind mode=0, i.e. no communication - ! (hence only scaling), then we do the halo - ! - call psb_ovrl(vtx,sm%desc_data,info,& - & update=psb_avg_,work=aux,mode=0) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - call sm%sv%apply(sone,vtx,szero,vty,sm%desc_data,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') - goto 9999 - endif - - select case(trans_) - case('N') - - select case (sm%prol) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,sm%desc_data,info,& - ! & update=sm%prol,work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(vty,sm%desc_data,info,& - & update=sm%prol,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - case('T','C') - ! - ! With transpose, we have to do it here - ! - if (sm%restr == psb_halo_) then - call psb_ovrl(vty,sm%desc_data,info,& - & update=psb_sum_,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - - - else if (sweeps > 1) then - - ! - ! - ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver - ! to compute an approximate solution of a linear system. - ! - ! - call vty%set(szero) - - do i=1, sweeps - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (sm%restr == psb_halo_) then - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - - case('T','C') - ! - ! With transpose, we have to do it here - ! - - select case (sm%prol) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case(psb_avg_) - ! - ! Tricky one: first we have to scale the overlap entries, - ! which we can do by assignind mode=0, i.e. no communication - ! (hence only scaling), then we do the halo - ! - call psb_ovrl(vtx,sm%desc_data,info,& - & update=psb_avg_,work=aux,mode=0) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - ! - ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the - ! block diagonal part and the remaining part of the local matrix - ! and Y(j) is the approximate solution at sweep j. - ! - call psb_geaxpby(sone,vtx,szero,vww,sm%desc_data,info) - call psb_spmm(-sone,sm%nd,vty,sone,vww,sm%desc_data,info,& - & work=aux,trans=trans_) - - if (info /= psb_success_) exit - - call sm%sv%apply(sone,vww,szero,vty,sm%desc_data,trans_,aux,info) - - if (info /= psb_success_) exit - - - select case(trans_) - case('N') - - select case (sm%prol) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,sm%desc_data,info,& - ! & update=sm%prol,work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(vty,sm%desc_data,info,& - & update=sm%prol,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - case('T','C') - ! - ! With transpose, we have to do it here - ! - if (sm%restr == psb_halo_) then - call psb_ovrl(vty,sm%desc_data,info,& - & update=psb_sum_,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - end do - - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 - end if - - - else - - info = psb_err_iarg_neg_ - call psb_errpush(info,name,& - & i_err=(/2,sweeps,0,0,0/)) - goto 9999 - - - end if - - ! - ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) - ! - call psb_geaxpby(alpha,vty,beta,y,desc_data,info) - - end if - - - if ((6*isz) <= size(work)) then - else if ((4*isz) <= size(work)) then - deallocate(ww,tx,ty) - else if ((3*isz) <= size(work)) then - deallocate(aux) - else - deallocate(ww,aux,tx,ty) - endif - call vww%free(info) - call vtx%free(info) - call vty%free(info) - - 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_as_smoother_apply_vect - - - subroutine s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - use psb_base_mod - type(psb_desc_type), intent(in) :: desc_data class(mld_s_as_smoother_type), intent(in) :: sm - real(psb_spk_),intent(inout) :: x(:) - real(psb_spk_),intent(inout) :: y(:) - real(psb_spk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans - integer, intent(in) :: sweeps - real(psb_spk_),target, intent(inout) :: work(:) - integer, intent(out) :: info - - integer :: n_row,n_col, nrow_d, i - real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) - integer :: ictxt,np,me, err_act,isz,int_err(5) - character :: trans_ - character(len=20) :: name='s_as_smoother_apply', ch_err - - call psb_erractionsave(err_act) - - info = psb_success_ - ictxt = desc_data%get_context() - call psb_info (ictxt,me,np) - - trans_ = psb_toupper(trans) - select case(trans_) - case('N') - case('T') - case('C') - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select - - if (.not.allocated(sm%sv)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - - n_row = sm%desc_data%get_local_rows() - n_col = sm%desc_data%get_local_cols() - nrow_d = desc_data%get_local_rows() - isz=max(n_row,N_COL) - if ((6*isz) <= size(work)) then - ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) - aux => work(3*isz+1:) - else if ((4*isz) <= size(work)) then - aux => work(1:) - allocate(ww(isz),tx(isz),ty(isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),& - & a_err='real(psb_spk_)') - goto 9999 - end if - else if ((3*isz) <= size(work)) then - ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) - allocate(aux(4*isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& - & a_err='real(psb_spk_)') - goto 9999 - end if - else - allocate(ww(isz),tx(isz),ty(isz),& - &aux(4*isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& - & a_err='real(psb_spk_)') - goto 9999 - end if - - endif - - if ((sm%novr == 0).and.(sweeps == 1)) then - ! - ! Shortcut: in this case it's just the same - ! as Block Jacobi. - ! - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') - goto 9999 - endif - - else - - - tx(1:nrow_d) = x(1:nrow_d) - tx(nrow_d+1:isz) = szero - - - if (sweeps == 1) then - - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (sm%restr == psb_halo_) then - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - - case('T','C') - ! - ! With transpose, we have to do it here - ! - - select case (sm%prol) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case(psb_avg_) - ! - ! Tricky one: first we have to scale the overlap entries, - ! which we can do by assignind mode=0, i.e. no communication - ! (hence only scaling), then we do the halo - ! - call psb_ovrl(tx,sm%desc_data,info,& - & update=psb_avg_,work=aux,mode=0) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - call sm%sv%apply(sone,tx,szero,ty,sm%desc_data,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') - goto 9999 - endif - - select case(trans_) - case('N') - - select case (sm%prol) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,sm%desc_data,info,& - ! & update=sm%prol,work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(ty,sm%desc_data,info,& - & update=sm%prol,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - case('T','C') - ! - ! With transpose, we have to do it here - ! - if (sm%restr == psb_halo_) then - call psb_ovrl(ty,sm%desc_data,info,& - & update=psb_sum_,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - - - else if (sweeps > 1) then - - ! - ! - ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver - ! to compute an approximate solution of a linear system. - ! - ! - ty = szero - do i=1, sweeps - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (sm%restr == psb_halo_) then - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - - case('T','C') - ! - ! With transpose, we have to do it here - ! - - select case (sm%prol) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case(psb_avg_) - ! - ! Tricky one: first we have to scale the overlap entries, - ! which we can do by assignind mode=0, i.e. no communication - ! (hence only scaling), then we do the halo - ! - call psb_ovrl(tx,sm%desc_data,info,& - & update=psb_avg_,work=aux,mode=0) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - ! - ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the - ! block diagonal part and the remaining part of the local matrix - ! and Y(j) is the approximate solution at sweep j. - ! - ww(1:n_row) = tx(1:n_row) - call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,work=aux,trans=trans_) - - if (info /= psb_success_) exit - - call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info) - - if (info /= psb_success_) exit - - - select case(trans_) - case('N') - - select case (sm%prol) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,sm%desc_data,info,& - ! & update=sm%prol,work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(ty,sm%desc_data,info,& - & update=sm%prol,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - case('T','C') - ! - ! With transpose, we have to do it here - ! - if (sm%restr == psb_halo_) then - call psb_ovrl(ty,sm%desc_data,info,& - & update=psb_sum_,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - end do - - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1') - goto 9999 - end if - - - else - - info = psb_err_iarg_neg_ - call psb_errpush(info,name,& - & i_err=(/2,sweeps,0,0,0/)) - goto 9999 - - - end if - - ! - ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) - ! - call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - - end if - - - if ((6*isz) <= size(work)) then - else if ((4*isz) <= size(work)) then - deallocate(ww,tx,ty) - else if ((3*isz) <= size(work)) then - deallocate(aux) - else - deallocate(ww,aux,tx,ty) - endif - - 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_as_smoother_apply - - subroutine s_as_smoother_bld(a,desc_a,sm,upd,info,amold,vmold) - - use psb_base_mod - - Implicit None - - ! Arguments - type(psb_sspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(in) :: desc_a - class(mld_s_as_smoother_type), intent(inout) :: sm - character, intent(in) :: upd - integer, intent(out) :: info - class(psb_s_base_sparse_mat), intent(in), optional :: amold - class(psb_s_base_vect_type), intent(in), optional :: vmold - - ! Local variables - type(psb_sspmat_type) :: blck, atmp - integer :: n_row,n_col, nrow_a, nhalo, novr, data_, nzeros - real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) - integer :: ictxt,np,me,i, err_act, debug_unit, debug_level - character(len=20) :: name='s_as_smoother_bld', ch_err - - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),' start' - - - novr = sm%novr - if (novr < 0) then - info=psb_err_invalid_ovr_num_ - call psb_errpush(info,name,i_err=(/novr,0,0,0,0,0/)) - goto 9999 - endif - - if ((novr == 0).or.(np == 1)) then - if (psb_toupper(upd) == 'F') then - call psb_cdcpy(desc_a,sm%desc_data,info) - If(debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' sone cdcpy' - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_cdcpy' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Early return: P>=3 N_OVR=0' - endif - call blck%csall(0,0,info,1) - else - - If (psb_toupper(upd) == 'F') Then - ! - ! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_). - ! This is sone by psb_cdbldext (interface to psb_cdovr), which is - ! independent of CSR, and has been placed in the tools directory - ! of PSBLAS, instead of the mlprec directory of MLD2P4, because it - ! might be used independently of the AS preconditioner, to build - ! a descriptor for an extended stencil in a PDE solver. - ! - call psb_cdbldext(a,desc_a,novr,sm%desc_data,info,extype=psb_ovt_asov_) - if(debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' From cdbldext _:',sm%desc_data%get_local_rows(),& - & sm%desc_data%get_local_cols() - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_cdbldext' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - Endif - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Before sphalo ' - - ! - ! Retrieve the remote sparse matrix rows required for the AS extended - ! matrix - data_ = psb_comm_ext_ - Call psb_sphalo(a,sm%desc_data,blck,info,data=data_,rowscale=.true.) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sphalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if (debug_level >=psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'After psb_sphalo ',& - & blck%get_nrows(), blck%get_nzeros() - - End if - if (info == psb_success_) & - & call sm%sv%build(a,sm%desc_data,upd,info,& - & blck,amold=amold,vmold=vmold) - - nrow_a = a%get_nrows() - n_row = sm%desc_data%get_local_rows() - n_col = sm%desc_data%get_local_cols() - - if (info == psb_success_) call a%csclip(sm%nd,info,& - & jmin=nrow_a+1,rscale=.false.,cscale=.false.) - if (info == psb_success_) call blck%csclip(atmp,info,& - & jmin=nrow_a+1,rscale=.false.,cscale=.false.) - if (info == psb_success_) call psb_rwextd(n_row,sm%nd,info,b=atmp) - - if (info == psb_success_) then - if (present(amold)) then - call sm%nd%cscnv(info,& - & mold=amold,dupl=psb_dupl_add_) - else - call sm%nd%cscnv(info,& - & type='csr',dupl=psb_dupl_add_) - end if - end if - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4') - goto 9999 - end if - nzeros = sm%nd%get_nzeros() -!!$ write(0,*) me,' ND nzeors ',nzeros - call psb_sum(ictxt,nzeros) - sm%nd_nnz_tot = nzeros - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),' end' - - 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_as_smoother_bld - - - subroutine s_as_smoother_seti(sm,what,val,info) - - use psb_base_mod - - Implicit None - - ! Arguments - class(mld_s_as_smoother_type), intent(inout) :: sm - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='s_as_smoother_seti' - - info = psb_success_ - 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_) - sm%restr = val - case(mld_sub_prol_) - sm%prol = val - case default - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if - end select + integer(psb_long_int_k_) :: val + integer :: i - call psb_erractionrestore(err_act) - return + val = psb_sizeof_int + if (allocated(sm%sv)) val = val + sm%sv%sizeof() + val = val + sm%nd%sizeof() -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return - end subroutine s_as_smoother_seti - - subroutine s_as_smoother_setc(sm,what,val,info) - - use psb_base_mod - - Implicit None - - ! Arguments - class(mld_s_as_smoother_type), intent(inout) :: sm - integer, intent(in) :: what - character(len=*), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, ival - character(len=20) :: name='s_as_smoother_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - - call mld_stringval(val,ival,info) - if (info == psb_success_) call sm%set(what,ival,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info, name) - goto 9999 - end if + end function s_as_smoother_sizeof - call psb_erractionrestore(err_act) - return + function s_as_smoother_get_nzeros(sm) result(val) + implicit none + class(mld_s_as_smoother_type), intent(in) :: sm + integer(psb_long_int_k_) :: val + integer :: i + val = 0 + if (allocated(sm%sv)) & + & val = sm%sv%get_nzeros() + val = val + sm%nd%get_nzeros() -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine s_as_smoother_setc + end function s_as_smoother_get_nzeros - subroutine s_as_smoother_setr(sm,what,val,info) + subroutine s_as_smoother_default(sm) - use psb_base_mod + use psb_base_mod, only : psb_halo_, psb_none_ Implicit None ! Arguments class(mld_s_as_smoother_type), intent(inout) :: sm - integer, intent(in) :: what - real(psb_spk_), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='s_as_smoother_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - else -!!$ write(0,*) trim(name),' Missing component, not setting!' -!!$ info = 1121 - 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_as_smoother_setr - - subroutine s_as_smoother_free(sm,info) - - use psb_base_mod - - Implicit None - - ! Arguments - class(mld_s_as_smoother_type), intent(inout) :: sm - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='s_as_smoother_free' - - call psb_erractionsave(err_act) - info = psb_success_ + sm%restr = psb_halo_ + sm%prol = psb_none_ + sm%novr = 1 if (allocated(sm%sv)) then - call sm%sv%free(info) - if (info == psb_success_) deallocate(sm%sv,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + call sm%sv%default() end if - call sm%nd%free() - call psb_erractionrestore(err_act) return + end subroutine s_as_smoother_default -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine s_as_smoother_free subroutine s_as_smoother_descr(sm,info,iout,coarse) @@ -1419,77 +296,4 @@ contains return end subroutine s_as_smoother_descr - function s_as_smoother_sizeof(sm) result(val) - use psb_base_mod - implicit none - ! Arguments - class(mld_s_as_smoother_type), intent(in) :: sm - integer(psb_long_int_k_) :: val - integer :: i - - val = psb_sizeof_int - if (allocated(sm%sv)) val = val + sm%sv%sizeof() - val = val + sm%nd%sizeof() - - return - end function s_as_smoother_sizeof - - function s_as_smoother_get_nzeros(sm) result(val) - implicit none - class(mld_s_as_smoother_type), intent(in) :: sm - integer(psb_long_int_k_) :: val - integer :: i - val = 0 - if (allocated(sm%sv)) & - & val = sm%sv%get_nzeros() - val = val + sm%nd%get_nzeros() - - end function s_as_smoother_get_nzeros - - subroutine s_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) - use psb_base_mod - implicit none - class(mld_s_as_smoother_type), intent(in) :: sm - integer, intent(in) :: ictxt,level - integer, intent(out) :: info - character(len=*), intent(in), optional :: prefix, head - logical, optional, intent(in) :: smoother, solver - integer :: i, j, il1, iln, lname, lev - integer :: icontxt,iam, np - character(len=80) :: prefix_ - character(len=120) :: fname ! len should be at least 20 more than - logical :: smoother_ - ! len of prefix_ - - info = 0 - - if (present(prefix)) then - prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) - else - prefix_ = "dump_smth_d" - end if - - call psb_info(ictxt,iam,np) - - if (present(smoother)) then - smoother_ = smoother - else - smoother_ = .false. - end if - lname = len_trim(prefix_) - fname = trim(prefix_) - write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam - lname = lname + 5 - - if (smoother_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx' - if (sm%nd%is_asb()) & - & call sm%nd%print(fname,head=head) - end if - ! At base level do nothing for the smoother - if (allocated(sm%sv)) & - & call sm%sv%dump(ictxt,level,info,solver=solver) - - end subroutine s_as_smoother_dmp - end module mld_s_as_smoother diff --git a/mlprec/mld_s_inner_mod.f90 b/mlprec/mld_s_inner_mod.f90 index 0537fec8..d5aeb204 100644 --- a/mlprec/mld_s_inner_mod.f90 +++ b/mlprec/mld_s_inner_mod.f90 @@ -98,10 +98,10 @@ module mld_s_inner_mod interface mld_coarse_bld subroutine mld_scoarse_bld(a,desc_a,p,info) use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ - use mld_s_prec_type, only : mld_sonelev_type + use mld_s_prec_type, only : mld_s_onelev_type type(psb_sspmat_type), intent(in), target :: a type(psb_desc_type), intent(in), target :: desc_a - type(mld_sonelev_type), intent(inout), target :: p + type(mld_s_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_scoarse_bld end interface mld_coarse_bld @@ -133,11 +133,11 @@ module mld_s_inner_mod interface mld_aggrmat_asb subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ - use mld_s_prec_type, only : mld_sonelev_type + use mld_s_prec_type, only : mld_s_onelev_type type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_sonelev_type), intent(inout), target :: p + type(mld_s_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_saggrmat_asb end interface mld_aggrmat_asb @@ -145,11 +145,11 @@ module mld_s_inner_mod interface mld_aggrmat_nosmth_asb subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ - use mld_s_prec_type, only : mld_sonelev_type + use mld_s_prec_type, only : mld_s_onelev_type type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_sonelev_type), intent(inout), target :: p + type(mld_s_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_saggrmat_nosmth_asb end interface mld_aggrmat_nosmth_asb @@ -157,11 +157,11 @@ module mld_s_inner_mod interface mld_aggrmat_smth_asb subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ - use mld_s_prec_type, only : mld_sonelev_type + use mld_s_prec_type, only : mld_s_onelev_type type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_sonelev_type), intent(inout), target :: p + type(mld_s_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_saggrmat_smth_asb end interface mld_aggrmat_smth_asb @@ -169,11 +169,11 @@ module mld_s_inner_mod interface mld_aggrmat_minnrg_asb subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ - use mld_s_prec_type, only : mld_sonelev_type + use mld_s_prec_type, only : mld_s_onelev_type type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_sonelev_type), intent(inout), target :: p + type(mld_s_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_saggrmat_minnrg_asb end interface mld_aggrmat_minnrg_asb diff --git a/mlprec/mld_s_move_alloc_mod.f90 b/mlprec/mld_s_move_alloc_mod.f90 index 07b59813..acb96e56 100644 --- a/mlprec/mld_s_move_alloc_mod.f90 +++ b/mlprec/mld_s_move_alloc_mod.f90 @@ -49,16 +49,16 @@ module mld_s_move_alloc_mod use mld_s_prec_type interface mld_move_alloc - module procedure mld_sonelev_prec_move_alloc,& + module procedure mld_s_onelev_prec_move_alloc,& & mld_sprec_move_alloc end interface contains - subroutine mld_sonelev_prec_move_alloc(a, b,info) + subroutine mld_s_onelev_prec_move_alloc(a, b,info) use psb_base_mod implicit none - type(mld_sonelev_type), intent(inout) :: a, b + type(mld_s_onelev_type), intent(inout) :: a, b integer, intent(out) :: info call b%free(info) @@ -69,7 +69,7 @@ contains b%base_a => a%base_a b%base_desc => a%base_desc - end subroutine mld_sonelev_prec_move_alloc + end subroutine mld_s_onelev_prec_move_alloc subroutine mld_sprec_move_alloc(a, b,info) use psb_base_mod diff --git a/mlprec/mld_s_onelev_mod.f90 b/mlprec/mld_s_onelev_mod.f90 index d74c8bd3..a0352543 100644 --- a/mlprec/mld_s_onelev_mod.f90 +++ b/mlprec/mld_s_onelev_mod.f90 @@ -118,7 +118,7 @@ module mld_s_onelev_mod ! get_nzeros - Number of nonzeros ! ! - type mld_sonelev_type + type mld_s_onelev_type class(mld_s_base_smoother_type), allocatable :: sm type(mld_sml_parms) :: parms type(psb_sspmat_type) :: ac @@ -139,7 +139,7 @@ module mld_s_onelev_mod generic, public :: set => seti, setr, setc procedure, pass(lv) :: sizeof => s_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => s_base_onelev_get_nzeros - end type mld_sonelev_type + end type mld_s_onelev_type private :: s_base_onelev_default, s_base_onelev_sizeof, & & s_base_onelev_nullify, s_base_onelev_get_nzeros @@ -149,10 +149,10 @@ module mld_s_onelev_mod interface mld_s_base_onelev_descr subroutine mld_s_base_onelev_descr(lv,il,nl,info,iout) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & - & psb_slinmap_type, psb_spk_, mld_sonelev_type, psb_long_int_k_, psb_desc_type + & psb_slinmap_type, psb_spk_, mld_s_onelev_type, psb_long_int_k_, psb_desc_type Implicit None ! Arguments - class(mld_sonelev_type), intent(in) :: lv + class(mld_s_onelev_type), intent(in) :: lv integer, intent(in) :: il,nl integer, intent(out) :: info integer, intent(in), optional :: iout @@ -162,10 +162,10 @@ module mld_s_onelev_mod interface mld_s_base_onelev_free subroutine mld_s_base_onelev_free(lv,info) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & - & psb_slinmap_type, psb_spk_, mld_sonelev_type, psb_long_int_k_, psb_desc_type + & psb_slinmap_type, psb_spk_, mld_s_onelev_type, psb_long_int_k_, psb_desc_type implicit none - class(mld_sonelev_type), intent(inout) :: lv + class(mld_s_onelev_type), intent(inout) :: lv integer, intent(out) :: info end subroutine mld_s_base_onelev_free end interface mld_s_base_onelev_free @@ -173,10 +173,10 @@ module mld_s_onelev_mod interface mld_s_base_onelev_check subroutine mld_s_base_onelev_check(lv,info) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & - & psb_slinmap_type, psb_spk_, mld_sonelev_type, psb_long_int_k_, psb_desc_type + & psb_slinmap_type, psb_spk_, mld_s_onelev_type, psb_long_int_k_, psb_desc_type Implicit None ! Arguments - class(mld_sonelev_type), intent(inout) :: lv + class(mld_s_onelev_type), intent(inout) :: lv integer, intent(out) :: info end subroutine mld_s_base_onelev_check end interface mld_s_base_onelev_check @@ -184,11 +184,11 @@ module mld_s_onelev_mod interface mld_s_base_onelev_seti subroutine mld_s_base_onelev_seti(lv,what,val,info) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & - & psb_slinmap_type, psb_spk_, mld_sonelev_type, psb_long_int_k_, psb_desc_type + & psb_slinmap_type, psb_spk_, mld_s_onelev_type, psb_long_int_k_, psb_desc_type Implicit None ! Arguments - class(mld_sonelev_type), intent(inout) :: lv + class(mld_s_onelev_type), intent(inout) :: lv integer, intent(in) :: what integer, intent(in) :: val integer, intent(out) :: info @@ -198,10 +198,10 @@ module mld_s_onelev_mod interface mld_s_base_onelev_setc subroutine mld_s_base_onelev_setc(lv,what,val,info) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & - & psb_slinmap_type, psb_spk_, mld_sonelev_type, psb_long_int_k_, psb_desc_type + & psb_slinmap_type, psb_spk_, mld_s_onelev_type, psb_long_int_k_, psb_desc_type Implicit None ! Arguments - class(mld_sonelev_type), intent(inout) :: lv + class(mld_s_onelev_type), intent(inout) :: lv integer, intent(in) :: what character(len=*), intent(in) :: val integer, intent(out) :: info @@ -211,10 +211,10 @@ module mld_s_onelev_mod interface mld_s_base_onelev_setr subroutine mld_s_base_onelev_setr(lv,what,val,info) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & - & psb_slinmap_type, psb_spk_, mld_sonelev_type, psb_long_int_k_, psb_desc_type + & psb_slinmap_type, psb_spk_, mld_s_onelev_type, psb_long_int_k_, psb_desc_type Implicit None - class(mld_sonelev_type), intent(inout) :: lv + class(mld_s_onelev_type), intent(inout) :: lv integer, intent(in) :: what real(psb_spk_), intent(in) :: val integer, intent(out) :: info @@ -224,9 +224,9 @@ module mld_s_onelev_mod interface mld_s_base_onelev_dump subroutine mld_s_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & - & psb_slinmap_type, psb_spk_, mld_sonelev_type, psb_long_int_k_, psb_desc_type + & psb_slinmap_type, psb_spk_, mld_s_onelev_type, psb_long_int_k_, psb_desc_type implicit none - class(mld_sonelev_type), intent(in) :: lv + class(mld_s_onelev_type), intent(in) :: lv integer, intent(in) :: level integer, intent(out) :: info character(len=*), intent(in), optional :: prefix, head @@ -243,7 +243,7 @@ contains function s_base_onelev_get_nzeros(lv) result(val) implicit none - class(mld_sonelev_type), intent(in) :: lv + class(mld_s_onelev_type), intent(in) :: lv integer(psb_long_int_k_) :: val integer :: i val = 0 @@ -253,7 +253,7 @@ contains function s_base_onelev_sizeof(lv) result(val) implicit none - class(mld_sonelev_type), intent(in) :: lv + class(mld_s_onelev_type), intent(in) :: lv integer(psb_long_int_k_) :: val integer :: i @@ -268,7 +268,7 @@ contains subroutine s_base_onelev_nullify(lv) implicit none - class(mld_sonelev_type), intent(inout) :: lv + class(mld_s_onelev_type), intent(inout) :: lv nullify(lv%base_a) nullify(lv%base_desc) @@ -290,7 +290,7 @@ contains Implicit None ! Arguments - class(mld_sonelev_type), intent(inout) :: lv + class(mld_s_onelev_type), intent(inout) :: lv lv%parms%sweeps = 1 lv%parms%sweeps_pre = 1 diff --git a/mlprec/mld_s_prec_type.f90 b/mlprec/mld_s_prec_type.f90 index f55b3c8e..b462a128 100644 --- a/mlprec/mld_s_prec_type.f90 +++ b/mlprec/mld_s_prec_type.f90 @@ -82,7 +82,7 @@ module mld_s_prec_type type, extends(psb_sprec_type) :: mld_sprec_type integer :: ictxt real(psb_spk_) :: op_complexity=szero - type(mld_sonelev_type), allocatable :: precv(:) + type(mld_s_onelev_type), allocatable :: precv(:) contains procedure, pass(prec) :: s_apply2_vect => mld_s_apply2_vect procedure, pass(prec) :: s_apply2v => mld_s_apply2v diff --git a/mlprec/mld_z_as_smoother.f90 b/mlprec/mld_z_as_smoother.f90 index 2395f72e..a0bc2f3d 100644 --- a/mlprec/mld_z_as_smoother.f90 +++ b/mlprec/mld_z_as_smoother.f90 @@ -55,15 +55,15 @@ module mld_z_as_smoother type(psb_desc_type) :: desc_data integer :: novr, restr, prol, nd_nnz_tot contains - procedure, pass(sm) :: check => z_as_smoother_check - procedure, pass(sm) :: dump => z_as_smoother_dmp - procedure, pass(sm) :: build => z_as_smoother_bld - procedure, pass(sm) :: apply_v => z_as_smoother_apply_vect - procedure, pass(sm) :: apply_a => z_as_smoother_apply - procedure, pass(sm) :: free => z_as_smoother_free - procedure, pass(sm) :: seti => z_as_smoother_seti - procedure, pass(sm) :: setc => z_as_smoother_setc - procedure, pass(sm) :: setr => z_as_smoother_setr + procedure, pass(sm) :: check => mld_z_as_smoother_check + procedure, pass(sm) :: dump => mld_z_as_smoother_dmp + procedure, pass(sm) :: build => mld_z_as_smoother_bld + procedure, pass(sm) :: apply_v => mld_z_as_smoother_apply_vect + procedure, pass(sm) :: apply_a => mld_z_as_smoother_apply + 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) :: descr => z_as_smoother_descr procedure, pass(sm) :: sizeof => z_as_smoother_sizeof procedure, pass(sm) :: default => z_as_smoother_default @@ -71,13 +71,8 @@ module mld_z_as_smoother end type mld_z_as_smoother_type - private :: z_as_smoother_bld, z_as_smoother_apply, & - & z_as_smoother_free, z_as_smoother_seti, & - & z_as_smoother_setc, z_as_smoother_setr,& - & z_as_smoother_descr, z_as_smoother_sizeof, & - & z_as_smoother_check, z_as_smoother_default,& - & z_as_smoother_dmp, z_as_smoother_apply_vect,& - & z_as_smoother_get_nzeros + private :: z_as_smoother_descr, z_as_smoother_sizeof, & + & z_as_smoother_default, z_as_smoother_get_nzeros character(len=6), parameter, private :: & & restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/) @@ -85,1284 +80,166 @@ module mld_z_as_smoother & prolong_names(0:3)=(/'none ','sum ','average ','square root'/) + interface mld_z_as_smoother_check + subroutine mld_z_as_smoother_check(sm,info) + import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & + & psb_dpk_, mld_z_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_z_as_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + end subroutine mld_z_as_smoother_check + end interface mld_z_as_smoother_check + + interface mld_z_as_smoother_apply_vect + subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & + & psb_dpk_, mld_z_as_smoother_type, psb_long_int_k_, psb_desc_type + type(psb_desc_type), intent(in) :: desc_data + class(mld_z_as_smoother_type), intent(inout) :: sm + type(psb_z_vect_type),intent(inout) :: x + type(psb_z_vect_type),intent(inout) :: y + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + integer, intent(in) :: sweeps + complex(psb_dpk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + end subroutine mld_z_as_smoother_apply_vect + end interface mld_z_as_smoother_apply_vect + + interface mld_z_as_smoother_apply + subroutine mld_z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & + & psb_dpk_, mld_z_as_smoother_type, psb_long_int_k_, psb_desc_type + type(psb_desc_type), intent(in) :: desc_data + class(mld_z_as_smoother_type), intent(in) :: sm + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(inout) :: y(:) + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + integer, intent(in) :: sweeps + complex(psb_dpk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + end subroutine mld_z_as_smoother_apply + end interface mld_z_as_smoother_apply + + interface mld_z_as_smoother_bld + subroutine mld_z_as_smoother_bld(a,desc_a,sm,upd,info,amold,vmold) + import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & + & psb_dpk_, mld_z_as_smoother_type, psb_long_int_k_, & + & psb_desc_type, psb_z_base_sparse_mat + type(psb_zspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_z_as_smoother_type), intent(inout) :: sm + character, intent(in) :: upd + integer, intent(out) :: info + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + end subroutine mld_z_as_smoother_bld + end interface mld_z_as_smoother_bld + + interface mld_z_as_smoother_seti + subroutine mld_z_as_smoother_seti(sm,what,val,info) + import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & + & psb_dpk_, mld_z_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_z_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + end subroutine mld_z_as_smoother_seti + end interface mld_z_as_smoother_seti + + interface mld_z_as_smoother_setc + subroutine mld_z_as_smoother_setc(sm,what,val,info) + import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & + & psb_dpk_, mld_z_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_z_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + character(len=*), intent(in) :: val + integer, intent(out) :: info + end subroutine mld_z_as_smoother_setc + end interface mld_z_as_smoother_setc + + interface mld_z_as_smoother_setr + subroutine mld_z_as_smoother_setr(sm,what,val,info) + import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & + & psb_dpk_, mld_z_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_z_as_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + real(psb_dpk_), intent(in) :: val + integer, intent(out) :: info + end subroutine mld_z_as_smoother_setr + end interface mld_z_as_smoother_setr + + interface mld_z_as_smoother_free + subroutine mld_z_as_smoother_free(sm,info) + import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & + & psb_dpk_, mld_z_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_z_as_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + end subroutine mld_z_as_smoother_free + end interface mld_z_as_smoother_free + + interface mld_z_as_smoother_dmp + subroutine mld_z_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) + import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & + & psb_dpk_, mld_z_as_smoother_type, psb_long_int_k_, psb_desc_type + class(mld_z_as_smoother_type), intent(in) :: sm + integer, intent(in) :: ictxt,level + integer, intent(out) :: info + character(len=*), intent(in), optional :: prefix, head + logical, optional, intent(in) :: smoother, solver + end subroutine mld_z_as_smoother_dmp + end interface mld_z_as_smoother_dmp + contains - subroutine z_as_smoother_default(sm) - - use psb_base_mod - - Implicit None - - ! Arguments - class(mld_z_as_smoother_type), intent(inout) :: sm - - - sm%restr = psb_halo_ - sm%prol = psb_none_ - sm%novr = 1 - - - if (allocated(sm%sv)) then - call sm%sv%default() - end if - - return - end subroutine z_as_smoother_default - - subroutine z_as_smoother_check(sm,info) - - use psb_base_mod - - Implicit None - + function z_as_smoother_sizeof(sm) result(val) + implicit none ! Arguments - class(mld_z_as_smoother_type), intent(inout) :: sm - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='z_as_smoother_check' - - call psb_erractionsave(err_act) - info = psb_success_ - - call mld_check_def(sm%restr,& - & 'Restrictor',psb_halo_,is_legal_restrict) - call mld_check_def(sm%prol,& - & 'Prolongator',psb_none_,is_legal_prolong) - call mld_check_def(sm%novr,& - & 'Overlap layers ',0,is_legal_n_ovr) - - - if (allocated(sm%sv)) then - call sm%sv%check(info) - else - info=3111 - call psb_errpush(info,name) - goto 9999 - end if - - if (info /= psb_success_) goto 9999 - - 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_as_smoother_check - - subroutine z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - use psb_base_mod - type(psb_desc_type), intent(in) :: desc_data - class(mld_z_as_smoother_type), intent(inout) :: sm - type(psb_z_vect_type),intent(inout) :: x - type(psb_z_vect_type),intent(inout) :: y - complex(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans - integer, intent(in) :: sweeps - complex(psb_dpk_),target, intent(inout) :: work(:) - integer, intent(out) :: info - - integer :: n_row,n_col, nrow_d, i - complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) - complex(psb_dpk_), allocatable :: vx(:) - type(psb_z_vect_type) :: vtx, vty, vww - integer :: ictxt,np,me, err_act,isz,int_err(5) - character :: trans_ - character(len=20) :: name='z_as_smoother_apply', ch_err - - call psb_erractionsave(err_act) - - info = psb_success_ - ictxt = desc_data%get_context() - call psb_info(ictxt,me,np) - - trans_ = psb_toupper(trans) - select case(trans_) - case('N') - case('T') - case('C') - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select - - if (.not.allocated(sm%sv)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - - n_row = sm%desc_data%get_local_rows() - n_col = sm%desc_data%get_local_cols() - nrow_d = desc_data%get_local_rows() - isz = max(n_row,N_COL) - - if ((6*isz) <= size(work)) then - ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) - aux => work(3*isz+1:) - else if ((4*isz) <= size(work)) then - aux => work(1:) - allocate(ww(isz),tx(isz),ty(isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),& - & a_err='complex(psb_dpk_)') - goto 9999 - end if - else if ((3*isz) <= size(work)) then - ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) - allocate(aux(4*isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& - & a_err='complex(psb_dpk_)') - goto 9999 - end if - else - allocate(ww(isz),tx(isz),ty(isz),& - &aux(4*isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& - & a_err='complex(psb_dpk_)') - goto 9999 - end if - - endif - - if ((sm%novr == 0).and.(sweeps == 1)) then - ! - ! Shortcut: in this case it's just the same - ! as Block Jacobi. - ! - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') - goto 9999 - endif - - else - - - vx = x%get_vect() - - call psb_geall(vtx,sm%desc_data,info) - call psb_geasb(vtx,sm%desc_data,info,mold=x%v) - call psb_geall(vty,sm%desc_data,info) - call psb_geasb(vty,sm%desc_data,info,mold=x%v) - call psb_geall(vww,sm%desc_data,info) - call psb_geasb(vww,sm%desc_data,info,mold=x%v) - call vtx%set(zzero) - call vty%set(zzero) - call vww%set(zzero) - - - call vtx%set(vx(1:nrow_d)) - - if (sweeps == 1) then - - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (sm%restr == psb_halo_) then - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - - case('T','C') - ! - ! With transpose, we have to do it here - ! - - select case (sm%prol) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case(psb_avg_) - ! - ! Tricky one: first we have to scale the overlap entries, - ! which we can do by assignind mode=0, i.e. no communication - ! (hence only scaling), then we do the halo - ! - call psb_ovrl(vtx,sm%desc_data,info,& - & update=psb_avg_,work=aux,mode=0) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - call sm%sv%apply(zone,vtx,zzero,vty,sm%desc_data,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') - goto 9999 - endif - - select case(trans_) - case('N') - - select case (sm%prol) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,sm%desc_data,info,& - ! & update=sm%prol,work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(vty,sm%desc_data,info,& - & update=sm%prol,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - case('T','C') - ! - ! With transpose, we have to do it here - ! - if (sm%restr == psb_halo_) then - call psb_ovrl(vty,sm%desc_data,info,& - & update=psb_sum_,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - - - else if (sweeps > 1) then - - ! - ! - ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver - ! to compute an approximate solution of a linear system. - ! - ! - call vty%set(zzero) - - do i=1, sweeps - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (sm%restr == psb_halo_) then - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - - case('T','C') - ! - ! With transpose, we have to do it here - ! - - select case (sm%prol) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case(psb_avg_) - ! - ! Tricky one: first we have to scale the overlap entries, - ! which we can do by assignind mode=0, i.e. no communication - ! (hence only scaling), then we do the halo - ! - call psb_ovrl(vtx,sm%desc_data,info,& - & update=psb_avg_,work=aux,mode=0) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - call psb_halo(vtx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - ! - ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the - ! block diagonal part and the remaining part of the local matrix - ! and Y(j) is the approximate solution at sweep j. - ! - call psb_geaxpby(zone,vtx,zzero,vww,sm%desc_data,info) - call psb_spmm(-zone,sm%nd,vty,zone,vww,sm%desc_data,info,& - & work=aux,trans=trans_) - - if (info /= psb_success_) exit - - call sm%sv%apply(zone,vww,zzero,vty,sm%desc_data,trans_,aux,info) - - if (info /= psb_success_) exit - - - select case(trans_) - case('N') - - select case (sm%prol) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,sm%desc_data,info,& - ! & update=sm%prol,work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(vty,sm%desc_data,info,& - & update=sm%prol,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - case('T','C') - ! - ! With transpose, we have to do it here - ! - if (sm%restr == psb_halo_) then - call psb_ovrl(vty,sm%desc_data,info,& - & update=psb_sum_,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - end do - - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 - end if - - - else - - info = psb_err_iarg_neg_ - call psb_errpush(info,name,& - & i_err=(/2,sweeps,0,0,0/)) - goto 9999 - - - end if - - ! - ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) - ! - call psb_geaxpby(alpha,vty,beta,y,desc_data,info) - - end if - - - if ((6*isz) <= size(work)) then - else if ((4*isz) <= size(work)) then - deallocate(ww,tx,ty) - else if ((3*isz) <= size(work)) then - deallocate(aux) - else - deallocate(ww,aux,tx,ty) - endif - call vww%free(info) - call vtx%free(info) - call vty%free(info) - - 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_as_smoother_apply_vect - - - subroutine z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - use psb_base_mod - type(psb_desc_type), intent(in) :: desc_data class(mld_z_as_smoother_type), intent(in) :: sm - complex(psb_dpk_),intent(inout) :: x(:) - complex(psb_dpk_),intent(inout) :: y(:) - complex(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans - integer, intent(in) :: sweeps - complex(psb_dpk_),target, intent(inout) :: work(:) - integer, intent(out) :: info - - integer :: n_row,n_col, nrow_d, i - complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) - integer :: ictxt,np,me, err_act,isz,int_err(5) - character :: trans_ - character(len=20) :: name='z_as_smoother_apply', ch_err - - call psb_erractionsave(err_act) - - info = psb_success_ - ictxt = desc_data%get_context() - call psb_info (ictxt,me,np) - - trans_ = psb_toupper(trans) - select case(trans_) - case('N') - case('T') - case('C') - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select - - if (.not.allocated(sm%sv)) then - info = 1121 - call psb_errpush(info,name) - goto 9999 - end if - - - n_row = sm%desc_data%get_local_rows() - n_col = sm%desc_data%get_local_cols() - nrow_d = desc_data%get_local_rows() - isz=max(n_row,N_COL) - if ((6*isz) <= size(work)) then - ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) - aux => work(3*isz+1:) - else if ((4*isz) <= size(work)) then - aux => work(1:) - allocate(ww(isz),tx(isz),ty(isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),& - & a_err='complex(psb_dpk_)') - goto 9999 - end if - else if ((3*isz) <= size(work)) then - ww => work(1:isz) - tx => work(isz+1:2*isz) - ty => work(2*isz+1:3*isz) - allocate(aux(4*isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& - & a_err='complex(psb_dpk_)') - goto 9999 - end if - else - allocate(ww(isz),tx(isz),ty(isz),& - &aux(4*isz),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),& - & a_err='complex(psb_dpk_)') - goto 9999 - end if - - endif - - if ((sm%novr == 0).and.(sweeps == 1)) then - ! - ! Shortcut: in this case it's just the same - ! as Block Jacobi. - ! - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') - goto 9999 - endif - - else - - - tx(1:nrow_d) = x(1:nrow_d) - tx(nrow_d+1:isz) = zzero - - - if (sweeps == 1) then - - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (sm%restr == psb_halo_) then - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - - case('T','C') - ! - ! With transpose, we have to do it here - ! - - select case (sm%prol) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case(psb_avg_) - ! - ! Tricky one: first we have to scale the overlap entries, - ! which we can do by assignind mode=0, i.e. no communication - ! (hence only scaling), then we do the halo - ! - call psb_ovrl(tx,sm%desc_data,info,& - & update=psb_avg_,work=aux,mode=0) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - call sm%sv%apply(zone,tx,zzero,ty,sm%desc_data,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') - goto 9999 - endif - - select case(trans_) - case('N') - - select case (sm%prol) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,sm%desc_data,info,& - ! & update=sm%prol,work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(ty,sm%desc_data,info,& - & update=sm%prol,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - case('T','C') - ! - ! With transpose, we have to do it here - ! - if (sm%restr == psb_halo_) then - call psb_ovrl(ty,sm%desc_data,info,& - & update=psb_sum_,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - - - else if (sweeps > 1) then - - ! - ! - ! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver - ! to compute an approximate solution of a linear system. - ! - ! - ty = zzero - do i=1, sweeps - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (sm%restr == psb_halo_) then - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - - case('T','C') - ! - ! With transpose, we have to do it here - ! - - select case (sm%prol) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case(psb_avg_) - ! - ! Tricky one: first we have to scale the overlap entries, - ! which we can do by assignind mode=0, i.e. no communication - ! (hence only scaling), then we do the halo - ! - call psb_ovrl(tx,sm%desc_data,info,& - & update=psb_avg_,work=aux,mode=0) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - ! - ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the - ! block diagonal part and the remaining part of the local matrix - ! and Y(j) is the approximate solution at sweep j. - ! - ww(1:n_row) = tx(1:n_row) - call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,work=aux,trans=trans_) - - if (info /= psb_success_) exit - - call sm%sv%apply(zone,ww,zzero,ty,sm%desc_data,trans_,aux,info) - - if (info /= psb_success_) exit - - - select case(trans_) - case('N') - - select case (sm%prol) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,sm%desc_data,info,& - ! & update=sm%prol,work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(ty,sm%desc_data,info,& - & update=sm%prol,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_') - goto 9999 - end select - - case('T','C') - ! - ! With transpose, we have to do it here - ! - if (sm%restr == psb_halo_) then - call psb_ovrl(ty,sm%desc_data,info,& - & update=psb_sum_,work=aux) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_ovrl' - goto 9999 - end if - else if (sm%restr /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - end do - - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1') - goto 9999 - end if - - - else - - info = psb_err_iarg_neg_ - call psb_errpush(info,name,& - & i_err=(/2,sweeps,0,0,0/)) - goto 9999 - - - end if - - ! - ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) - ! - call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - - end if - - - if ((6*isz) <= size(work)) then - else if ((4*isz) <= size(work)) then - deallocate(ww,tx,ty) - else if ((3*isz) <= size(work)) then - deallocate(aux) - else - deallocate(ww,aux,tx,ty) - endif - - 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_as_smoother_apply - - subroutine z_as_smoother_bld(a,desc_a,sm,upd,info,amold,vmold) - - use psb_base_mod - - Implicit None - - ! Arguments - type(psb_zspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(in) :: desc_a - class(mld_z_as_smoother_type), intent(inout) :: sm - character, intent(in) :: upd - integer, intent(out) :: info - class(psb_z_base_sparse_mat), intent(in), optional :: amold - class(psb_z_base_vect_type), intent(in), optional :: vmold - - ! Local variables - type(psb_zspmat_type) :: blck, atmp - integer :: n_row,n_col, nrow_a, nhalo, novr, data_, nzeros - complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) - integer :: ictxt,np,me,i, err_act, debug_unit, debug_level - character(len=20) :: name='z_as_smoother_bld', ch_err - - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),' start' - - - novr = sm%novr - if (novr < 0) then - info=psb_err_invalid_ovr_num_ - call psb_errpush(info,name,i_err=(/novr,0,0,0,0,0/)) - goto 9999 - endif - - if ((novr == 0).or.(np == 1)) then - if (psb_toupper(upd) == 'F') then - call psb_cdcpy(desc_a,sm%desc_data,info) - If(debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' zone cdcpy' - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_cdcpy' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Early return: P>=3 N_OVR=0' - endif - call blck%csall(0,0,info,1) - else - - If (psb_toupper(upd) == 'F') Then - ! - ! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_). - ! This is zone by psb_cdbldext (interface to psb_cdovr), which is - ! independent of CSR, and has been placed in the tools directory - ! of PSBLAS, instead of the mlprec directory of MLD2P4, because it - ! might be used independently of the AS preconditioner, to build - ! a descriptor for an extended stencil in a PDE solver. - ! - call psb_cdbldext(a,desc_a,novr,sm%desc_data,info,extype=psb_ovt_asov_) - if(debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' From cdbldext _:',sm%desc_data%get_local_rows(),& - & sm%desc_data%get_local_cols() - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_cdbldext' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - Endif - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Before sphalo ' - - ! - ! Retrieve the remote sparse matrix rows required for the AS extended - ! matrix - data_ = psb_comm_ext_ - Call psb_sphalo(a,sm%desc_data,blck,info,data=data_,rowscale=.true.) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sphalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if (debug_level >=psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'After psb_sphalo ',& - & blck%get_nrows(), blck%get_nzeros() - - End if - if (info == psb_success_) & - & call sm%sv%build(a,sm%desc_data,upd,info,& - & blck,amold=amold,vmold=vmold) - - nrow_a = a%get_nrows() - n_row = sm%desc_data%get_local_rows() - n_col = sm%desc_data%get_local_cols() - - if (info == psb_success_) call a%csclip(sm%nd,info,& - & jmin=nrow_a+1,rscale=.false.,cscale=.false.) - if (info == psb_success_) call blck%csclip(atmp,info,& - & jmin=nrow_a+1,rscale=.false.,cscale=.false.) - if (info == psb_success_) call psb_rwextd(n_row,sm%nd,info,b=atmp) - - if (info == psb_success_) then - if (present(amold)) then - call sm%nd%cscnv(info,& - & mold=amold,dupl=psb_dupl_add_) - else - call sm%nd%cscnv(info,& - & type='csr',dupl=psb_dupl_add_) - end if - end if - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4') - goto 9999 - end if - nzeros = sm%nd%get_nzeros() -!!$ write(0,*) me,' ND nzeors ',nzeros - call psb_sum(ictxt,nzeros) - sm%nd_nnz_tot = nzeros - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),' end' - - 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_as_smoother_bld - - - subroutine z_as_smoother_seti(sm,what,val,info) - - use psb_base_mod - - Implicit None - - ! Arguments - class(mld_z_as_smoother_type), intent(inout) :: sm - integer, intent(in) :: what - integer, intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='z_as_smoother_seti' - - info = psb_success_ - 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_) - sm%restr = val - case(mld_sub_prol_) - sm%prol = val - case default - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - end if - end select + integer(psb_long_int_k_) :: val + integer :: i - call psb_erractionrestore(err_act) - return + val = psb_sizeof_int + if (allocated(sm%sv)) val = val + sm%sv%sizeof() + val = val + sm%nd%sizeof() -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if return - end subroutine z_as_smoother_seti - - subroutine z_as_smoother_setc(sm,what,val,info) - - use psb_base_mod - - Implicit None - - ! Arguments - class(mld_z_as_smoother_type), intent(inout) :: sm - integer, intent(in) :: what - character(len=*), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act, ival - character(len=20) :: name='z_as_smoother_setc' - - info = psb_success_ - call psb_erractionsave(err_act) - - - call mld_stringval(val,ival,info) - if (info == psb_success_) call sm%set(what,ival,info) - if (info /= psb_success_) then - info = psb_err_from_subroutine_ - call psb_errpush(info, name) - goto 9999 - end if + end function z_as_smoother_sizeof - call psb_erractionrestore(err_act) - return + function z_as_smoother_get_nzeros(sm) result(val) + implicit none + class(mld_z_as_smoother_type), intent(in) :: sm + integer(psb_long_int_k_) :: val + integer :: i + val = 0 + if (allocated(sm%sv)) & + & val = sm%sv%get_nzeros() + val = val + sm%nd%get_nzeros() -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine z_as_smoother_setc + end function z_as_smoother_get_nzeros - subroutine z_as_smoother_setr(sm,what,val,info) + subroutine z_as_smoother_default(sm) - use psb_base_mod + use psb_base_mod, only : psb_halo_, psb_none_ Implicit None ! Arguments class(mld_z_as_smoother_type), intent(inout) :: sm - integer, intent(in) :: what - real(psb_dpk_), intent(in) :: val - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='z_as_smoother_setr' - - call psb_erractionsave(err_act) - info = psb_success_ - - if (allocated(sm%sv)) then - call sm%sv%set(what,val,info) - else -!!$ write(0,*) trim(name),' Missing component, not setting!' -!!$ info = 1121 - 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_as_smoother_setr - - subroutine z_as_smoother_free(sm,info) - - use psb_base_mod - - Implicit None - - ! Arguments - class(mld_z_as_smoother_type), intent(inout) :: sm - integer, intent(out) :: info - Integer :: err_act - character(len=20) :: name='z_as_smoother_free' - - call psb_erractionsave(err_act) - info = psb_success_ + sm%restr = psb_halo_ + sm%prol = psb_none_ + sm%novr = 1 if (allocated(sm%sv)) then - call sm%sv%free(info) - if (info == psb_success_) deallocate(sm%sv,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if + call sm%sv%default() end if - call sm%nd%free() - call psb_erractionrestore(err_act) return + end subroutine z_as_smoother_default -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine z_as_smoother_free subroutine z_as_smoother_descr(sm,info,iout,coarse) @@ -1419,77 +296,4 @@ contains return end subroutine z_as_smoother_descr - function z_as_smoother_sizeof(sm) result(val) - use psb_base_mod - implicit none - ! Arguments - class(mld_z_as_smoother_type), intent(in) :: sm - integer(psb_long_int_k_) :: val - integer :: i - - val = psb_sizeof_int - if (allocated(sm%sv)) val = val + sm%sv%sizeof() - val = val + sm%nd%sizeof() - - return - end function z_as_smoother_sizeof - - function z_as_smoother_get_nzeros(sm) result(val) - implicit none - class(mld_z_as_smoother_type), intent(in) :: sm - integer(psb_long_int_k_) :: val - integer :: i - val = 0 - if (allocated(sm%sv)) & - & val = sm%sv%get_nzeros() - val = val + sm%nd%get_nzeros() - - end function z_as_smoother_get_nzeros - - subroutine z_as_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) - use psb_base_mod - implicit none - class(mld_z_as_smoother_type), intent(in) :: sm - integer, intent(in) :: ictxt,level - integer, intent(out) :: info - character(len=*), intent(in), optional :: prefix, head - logical, optional, intent(in) :: smoother, solver - integer :: i, j, il1, iln, lname, lev - integer :: icontxt,iam, np - character(len=80) :: prefix_ - character(len=120) :: fname ! len should be at least 20 more than - logical :: smoother_ - ! len of prefix_ - - info = 0 - - if (present(prefix)) then - prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) - else - prefix_ = "dump_smth_d" - end if - - call psb_info(ictxt,iam,np) - - if (present(smoother)) then - smoother_ = smoother - else - smoother_ = .false. - end if - lname = len_trim(prefix_) - fname = trim(prefix_) - write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam - lname = lname + 5 - - if (smoother_) then - write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_nd.mtx' - if (sm%nd%is_asb()) & - & call sm%nd%print(fname,head=head) - end if - ! At base level do nothing for the smoother - if (allocated(sm%sv)) & - & call sm%sv%dump(ictxt,level,info,solver=solver) - - end subroutine z_as_smoother_dmp - end module mld_z_as_smoother diff --git a/mlprec/mld_z_inner_mod.f90 b/mlprec/mld_z_inner_mod.f90 index 62ff1c78..647e1b88 100644 --- a/mlprec/mld_z_inner_mod.f90 +++ b/mlprec/mld_z_inner_mod.f90 @@ -98,10 +98,10 @@ module mld_z_inner_mod interface mld_coarse_bld subroutine mld_zcoarse_bld(a,desc_a,p,info) use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ - use mld_z_prec_type, only : mld_zonelev_type + use mld_z_prec_type, only : mld_z_onelev_type type(psb_zspmat_type), intent(in), target :: a type(psb_desc_type), intent(in), target :: desc_a - type(mld_zonelev_type), intent(inout), target :: p + type(mld_z_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_zcoarse_bld end interface mld_coarse_bld @@ -133,11 +133,11 @@ module mld_z_inner_mod interface mld_aggrmat_asb subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ - use mld_z_prec_type, only : mld_zonelev_type + use mld_z_prec_type, only : mld_z_onelev_type type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_zonelev_type), intent(inout), target :: p + type(mld_z_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_zaggrmat_asb end interface mld_aggrmat_asb @@ -145,11 +145,11 @@ module mld_z_inner_mod interface mld_aggrmat_nosmth_asb subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ - use mld_z_prec_type, only : mld_zonelev_type + use mld_z_prec_type, only : mld_z_onelev_type type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_zonelev_type), intent(inout), target :: p + type(mld_z_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_zaggrmat_nosmth_asb end interface mld_aggrmat_nosmth_asb @@ -157,11 +157,11 @@ module mld_z_inner_mod interface mld_aggrmat_smth_asb subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ - use mld_z_prec_type, only : mld_zonelev_type + use mld_z_prec_type, only : mld_z_onelev_type type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_zonelev_type), intent(inout), target :: p + type(mld_z_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_zaggrmat_smth_asb end interface mld_aggrmat_smth_asb @@ -169,11 +169,11 @@ module mld_z_inner_mod interface mld_aggrmat_minnrg_asb subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ - use mld_z_prec_type, only : mld_zonelev_type + use mld_z_prec_type, only : mld_z_onelev_type type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_zonelev_type), intent(inout), target :: p + type(mld_z_onelev_type), intent(inout), target :: p integer, intent(out) :: info end subroutine mld_zaggrmat_minnrg_asb end interface mld_aggrmat_minnrg_asb diff --git a/mlprec/mld_z_move_alloc_mod.f90 b/mlprec/mld_z_move_alloc_mod.f90 index 0dc10bcb..75c967b7 100644 --- a/mlprec/mld_z_move_alloc_mod.f90 +++ b/mlprec/mld_z_move_alloc_mod.f90 @@ -49,16 +49,16 @@ module mld_z_move_alloc_mod use mld_z_prec_type interface mld_move_alloc - module procedure mld_zonelev_prec_move_alloc,& + module procedure mld_z_onelev_prec_move_alloc,& & mld_zprec_move_alloc end interface contains - subroutine mld_zonelev_prec_move_alloc(a, b,info) + subroutine mld_z_onelev_prec_move_alloc(a, b,info) use psb_base_mod implicit none - type(mld_zonelev_type), intent(inout) :: a, b + type(mld_z_onelev_type), intent(inout) :: a, b integer, intent(out) :: info call b%free(info) @@ -69,7 +69,7 @@ contains b%base_a => a%base_a b%base_desc => a%base_desc - end subroutine mld_zonelev_prec_move_alloc + end subroutine mld_z_onelev_prec_move_alloc subroutine mld_zprec_move_alloc(a, b,info) use psb_base_mod diff --git a/mlprec/mld_z_onelev_mod.f90 b/mlprec/mld_z_onelev_mod.f90 index be15c6c1..43b1bd3f 100644 --- a/mlprec/mld_z_onelev_mod.f90 +++ b/mlprec/mld_z_onelev_mod.f90 @@ -118,7 +118,7 @@ module mld_z_onelev_mod ! get_nzeros - Number of nonzeros ! ! - type mld_zonelev_type + type mld_z_onelev_type class(mld_z_base_smoother_type), allocatable :: sm type(mld_dml_parms) :: parms type(psb_zspmat_type) :: ac @@ -139,7 +139,7 @@ module mld_z_onelev_mod generic, public :: set => seti, setr, setc procedure, pass(lv) :: sizeof => z_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => z_base_onelev_get_nzeros - end type mld_zonelev_type + end type mld_z_onelev_type private :: z_base_onelev_default, z_base_onelev_sizeof, & & z_base_onelev_nullify, z_base_onelev_get_nzeros @@ -149,10 +149,10 @@ module mld_z_onelev_mod interface mld_z_base_onelev_descr subroutine mld_z_base_onelev_descr(lv,il,nl,info,iout) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & - & psb_zlinmap_type, psb_dpk_, mld_zonelev_type, psb_long_int_k_, psb_desc_type + & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, psb_long_int_k_, psb_desc_type Implicit None ! Arguments - class(mld_zonelev_type), intent(in) :: lv + class(mld_z_onelev_type), intent(in) :: lv integer, intent(in) :: il,nl integer, intent(out) :: info integer, intent(in), optional :: iout @@ -162,10 +162,10 @@ module mld_z_onelev_mod interface mld_z_base_onelev_free subroutine mld_z_base_onelev_free(lv,info) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & - & psb_zlinmap_type, psb_dpk_, mld_zonelev_type, psb_long_int_k_, psb_desc_type + & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, psb_long_int_k_, psb_desc_type implicit none - class(mld_zonelev_type), intent(inout) :: lv + class(mld_z_onelev_type), intent(inout) :: lv integer, intent(out) :: info end subroutine mld_z_base_onelev_free end interface mld_z_base_onelev_free @@ -173,10 +173,10 @@ module mld_z_onelev_mod interface mld_z_base_onelev_check subroutine mld_z_base_onelev_check(lv,info) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & - & psb_zlinmap_type, psb_dpk_, mld_zonelev_type, psb_long_int_k_, psb_desc_type + & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, psb_long_int_k_, psb_desc_type Implicit None ! Arguments - class(mld_zonelev_type), intent(inout) :: lv + class(mld_z_onelev_type), intent(inout) :: lv integer, intent(out) :: info end subroutine mld_z_base_onelev_check end interface mld_z_base_onelev_check @@ -184,11 +184,11 @@ module mld_z_onelev_mod interface mld_z_base_onelev_seti subroutine mld_z_base_onelev_seti(lv,what,val,info) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & - & psb_zlinmap_type, psb_dpk_, mld_zonelev_type, psb_long_int_k_, psb_desc_type + & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, psb_long_int_k_, psb_desc_type Implicit None ! Arguments - class(mld_zonelev_type), intent(inout) :: lv + class(mld_z_onelev_type), intent(inout) :: lv integer, intent(in) :: what integer, intent(in) :: val integer, intent(out) :: info @@ -198,10 +198,10 @@ module mld_z_onelev_mod interface mld_z_base_onelev_setc subroutine mld_z_base_onelev_setc(lv,what,val,info) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & - & psb_zlinmap_type, psb_dpk_, mld_zonelev_type, psb_long_int_k_, psb_desc_type + & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, psb_long_int_k_, psb_desc_type Implicit None ! Arguments - class(mld_zonelev_type), intent(inout) :: lv + class(mld_z_onelev_type), intent(inout) :: lv integer, intent(in) :: what character(len=*), intent(in) :: val integer, intent(out) :: info @@ -211,10 +211,10 @@ module mld_z_onelev_mod interface mld_z_base_onelev_setr subroutine mld_z_base_onelev_setr(lv,what,val,info) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & - & psb_zlinmap_type, psb_dpk_, mld_zonelev_type, psb_long_int_k_, psb_desc_type + & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, psb_long_int_k_, psb_desc_type Implicit None - class(mld_zonelev_type), intent(inout) :: lv + class(mld_z_onelev_type), intent(inout) :: lv integer, intent(in) :: what real(psb_dpk_), intent(in) :: val integer, intent(out) :: info @@ -224,9 +224,9 @@ module mld_z_onelev_mod interface mld_z_base_onelev_dump subroutine mld_z_base_onelev_dump(lv,level,info,prefix,head,ac,rp,smoother,solver) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & - & psb_zlinmap_type, psb_dpk_, mld_zonelev_type, psb_long_int_k_, psb_desc_type + & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, psb_long_int_k_, psb_desc_type implicit none - class(mld_zonelev_type), intent(in) :: lv + class(mld_z_onelev_type), intent(in) :: lv integer, intent(in) :: level integer, intent(out) :: info character(len=*), intent(in), optional :: prefix, head @@ -243,7 +243,7 @@ contains function z_base_onelev_get_nzeros(lv) result(val) implicit none - class(mld_zonelev_type), intent(in) :: lv + class(mld_z_onelev_type), intent(in) :: lv integer(psb_long_int_k_) :: val integer :: i val = 0 @@ -253,7 +253,7 @@ contains function z_base_onelev_sizeof(lv) result(val) implicit none - class(mld_zonelev_type), intent(in) :: lv + class(mld_z_onelev_type), intent(in) :: lv integer(psb_long_int_k_) :: val integer :: i @@ -268,7 +268,7 @@ contains subroutine z_base_onelev_nullify(lv) implicit none - class(mld_zonelev_type), intent(inout) :: lv + class(mld_z_onelev_type), intent(inout) :: lv nullify(lv%base_a) nullify(lv%base_desc) @@ -290,7 +290,7 @@ contains Implicit None ! Arguments - class(mld_zonelev_type), intent(inout) :: lv + class(mld_z_onelev_type), intent(inout) :: lv lv%parms%sweeps = 1 lv%parms%sweeps_pre = 1 diff --git a/mlprec/mld_z_prec_type.f90 b/mlprec/mld_z_prec_type.f90 index c1bf0b66..d9ceeaa4 100644 --- a/mlprec/mld_z_prec_type.f90 +++ b/mlprec/mld_z_prec_type.f90 @@ -82,7 +82,7 @@ module mld_z_prec_type type, extends(psb_zprec_type) :: mld_zprec_type integer :: ictxt real(psb_dpk_) :: op_complexity=dzero - type(mld_zonelev_type), allocatable :: precv(:) + type(mld_z_onelev_type), allocatable :: precv(:) contains procedure, pass(prec) :: z_apply2_vect => mld_z_apply2_vect procedure, pass(prec) :: z_apply2v => mld_z_apply2v