From df1464346523d75cb3ca554e8d2acb58d6f84c97 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 2 Nov 2010 16:06:32 +0000 Subject: [PATCH] mld2p4: Makefile mld_base_prec_type.f90 mld_d_prec_type.f03 mld_daggrmat_smth_asb.F90 mld_das_aply.f90 mld_das_bld.f90 mld_dbaseprec_aply.f90 mld_dbaseprec_bld.f90 mld_dilu_bld.f90 mld_move_alloc_mod.f90 mld_s_as_smoother.f03 mld_s_diag_solver.f03 mld_s_ilu_solver.f03 mld_s_prec_type.f03 mld_s_prec_type.f90 mld_saggrmap_bld.f90 mld_saggrmat_nosmth_asb.F90 mld_saggrmat_smth_asb.F90 mld_sas_aply.f90 mld_sas_bld.f90 mld_sbaseprec_aply.f90 mld_sbaseprec_bld.f90 mld_scoarse_bld.f90 mld_silu0_fact.f90 mld_silu_bld.f90 mld_siluk_fact.f90 mld_silut_fact.f90 Start of SINGLE PRECISION implementation. --- mlprec/Makefile | 19 +- mlprec/mld_base_prec_type.f90 | 3 +- mlprec/mld_d_prec_type.f03 | 2 +- mlprec/mld_daggrmat_smth_asb.F90 | 42 +- mlprec/mld_das_aply.f90 | 411 -------- mlprec/mld_das_bld.f90 | 270 ------ mlprec/mld_dbaseprec_aply.f90 | 189 ---- mlprec/mld_dbaseprec_bld.f90 | 215 ----- mlprec/mld_dilu_bld.f90 | 287 ------ mlprec/mld_move_alloc_mod.f90 | 12 +- mlprec/mld_s_as_smoother.f03 | 874 +++++++++++++++++ mlprec/mld_s_diag_solver.f03 | 466 +++++++++ mlprec/mld_s_ilu_solver.f03 | 606 ++++++++++++ mlprec/mld_s_prec_type.f03 | 1406 ++++++++++++++++++++++++++++ mlprec/mld_s_prec_type.f90 | 702 -------------- mlprec/mld_saggrmap_bld.f90 | 36 +- mlprec/mld_saggrmat_nosmth_asb.F90 | 122 +-- mlprec/mld_saggrmat_smth_asb.F90 | 400 ++++---- mlprec/mld_sas_aply.f90 | 407 -------- mlprec/mld_sas_bld.f90 | 287 ------ mlprec/mld_sbaseprec_aply.f90 | 189 ---- mlprec/mld_sbaseprec_bld.f90 | 215 ----- mlprec/mld_scoarse_bld.f90 | 12 +- mlprec/mld_silu0_fact.f90 | 490 +++++----- mlprec/mld_silu_bld.f90 | 280 ------ mlprec/mld_siluk_fact.f90 | 256 ++--- mlprec/mld_silut_fact.f90 | 299 +++--- 27 files changed, 4155 insertions(+), 4342 deletions(-) delete mode 100644 mlprec/mld_das_aply.f90 delete mode 100644 mlprec/mld_das_bld.f90 delete mode 100644 mlprec/mld_dbaseprec_aply.f90 delete mode 100644 mlprec/mld_dbaseprec_bld.f90 delete mode 100644 mlprec/mld_dilu_bld.f90 create mode 100644 mlprec/mld_s_as_smoother.f03 create mode 100644 mlprec/mld_s_diag_solver.f03 create mode 100644 mlprec/mld_s_ilu_solver.f03 create mode 100644 mlprec/mld_s_prec_type.f03 delete mode 100644 mlprec/mld_s_prec_type.f90 delete mode 100644 mlprec/mld_sas_aply.f90 delete mode 100644 mlprec/mld_sas_bld.f90 delete mode 100644 mlprec/mld_sbaseprec_aply.f90 delete mode 100644 mlprec/mld_sbaseprec_bld.f90 delete mode 100644 mlprec/mld_silu_bld.f90 diff --git a/mlprec/Makefile b/mlprec/Makefile index cff7a3ff..07d1c647 100644 --- a/mlprec/Makefile +++ b/mlprec/Makefile @@ -9,17 +9,16 @@ FINCLUDES=$(FMFLAG). $(FMFLAG)$(LIBDIR) $(FMFLAG)$(PSBLIBDIR) MODOBJS=mld_base_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_type.o mld_prec_mod.o mld_inner_mod.o mld_move_alloc_mod.o\ - mld_d_ilu_solver.o mld_d_diag_solver.o mld_d_jac_smoother.o mld_d_as_smoother.o -MPFOBJS=mld_daggrmat_nosmth_asb.o mld_daggrmat_smth_asb.o mld_daggrmat_minnrg_asb.o + mld_d_ilu_solver.o mld_d_diag_solver.o mld_d_jac_smoother.o mld_d_as_smoother.o \ + mld_s_ilu_solver.o mld_s_diag_solver.o mld_s_as_smoother.o +MPFOBJS=mld_daggrmat_nosmth_asb.o mld_daggrmat_smth_asb.o mld_daggrmat_minnrg_asb.o \ + mld_saggrmat_nosmth_asb.o mld_saggrmat_smth_asb.o MPCOBJS=mld_sslud_interface.o mld_dslud_interface.o mld_cslud_interface.o mld_zslud_interface.o -INNEROBJS= mld_dcoarse_bld.o \ - mld_dmlprec_bld.o\ - mld_dslu_bld.o mld_dumf_bld.o \ - mld_dilu0_fact.o \ - mld_diluk_fact.o mld_dilut_fact.o \ - mld_daggrmap_bld.o \ - mld_dmlprec_aply.o mld_dslud_bld.o\ - mld_daggrmat_asb.o \ +INNEROBJS= mld_dcoarse_bld.o mld_dmlprec_bld.o mld_dslu_bld.o mld_dumf_bld.o \ + mld_dilu0_fact.o mld_diluk_fact.o mld_dilut_fact.o mld_daggrmap_bld.o \ + mld_dmlprec_aply.o mld_dslud_bld.o mld_daggrmat_asb.o \ + mld_scoarse_bld.o mld_saggrmap_bld.o \ + mld_silu0_fact.o mld_siluk_fact.o mld_silut_fact.o \ $(MPFOBJS) # diff --git a/mlprec/mld_base_prec_type.f90 b/mlprec/mld_base_prec_type.f90 index e51d54fc..0dd9f1f4 100644 --- a/mlprec/mld_base_prec_type.f90 +++ b/mlprec/mld_base_prec_type.f90 @@ -74,7 +74,8 @@ module mld_base_prec_type & psb_sizeof_int, psb_sizeof_long_int, psb_sizeof_sp, psb_sizeof_dp, psb_sizeof,& & psb_cd_get_context, psb_info use psb_prec_mod, only: psb_sprec_type, psb_dprec_type,& - & psb_cprec_type, psb_zprec_type, psb_d_base_prec_type + & psb_cprec_type, psb_zprec_type,& + & psb_d_base_prec_type, psb_s_base_prec_type type mld_aux_onelev_map_type diff --git a/mlprec/mld_d_prec_type.f03 b/mlprec/mld_d_prec_type.f03 index 6b4f96f7..66ffc656 100644 --- a/mlprec/mld_d_prec_type.f03 +++ b/mlprec/mld_d_prec_type.f03 @@ -4,7 +4,7 @@ !!$ MultiLevel Domain Decomposition Parallel Preconditioners Package !!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) !!$ -!!$ (C) Copyright 2008,2009,2010, 2010 +!!$ (C) Copyright 2008,2009,2010 !!$ !!$ Salvatore Filippone University of Rome Tor Vergata !!$ Alfredo Buttari CNRS-IRIT, Toulouse diff --git a/mlprec/mld_daggrmat_smth_asb.F90 b/mlprec/mld_daggrmat_smth_asb.F90 index 79011a9f..4e31d838 100644 --- a/mlprec/mld_daggrmat_smth_asb.F90 +++ b/mlprec/mld_daggrmat_smth_asb.F90 @@ -299,10 +299,10 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) tmp = dzero do j=acsr3%irp(i),acsr3%irp(i+1)-1 if (acsr3%ja(j) <= nrw) then - tmp = tmp + dabs(acsr3%val(j)) + tmp = tmp + abs(acsr3%val(j)) endif if (acsr3%ja(j) == i ) then - dg = dabs(acsr3%val(j)) + dg = abs(acsr3%val(j)) end if end do anorm = max(anorm,tmp/dg) @@ -649,44 +649,6 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) if(info /= psb_success_) goto 9999 -!!$ -!!$ nzbr(:) = 0 -!!$ nzbr(me+1) = b%get_nzeros() -!!$ call psb_sum(ictxt,nzbr(1:np)) -!!$ nzac = sum(nzbr) -!!$ -!!$ call b%mv_to(bcoo) -!!$ call psb_sum(ictxt,nzbr(1:np)) -!!$ nzac = sum(nzbr) -!!$ if (info == psb_success_) call cootmp%allocate(ntaggr,ntaggr,nzac) -!!$ if (info /= psb_success_) goto 9999 -!!$ -!!$ do ip=1,np -!!$ idisp(ip) = sum(nzbr(1:ip-1)) -!!$ enddo -!!$ ndx = nzbr(me+1) -!!$ -!!$ call mpi_allgatherv(bcoo%val,ndx,mpi_double_precision,& -!!$ & cootmp%val,nzbr,idisp,& -!!$ & mpi_double_precision,icomm,info) -!!$ if (info == psb_success_) call mpi_allgatherv(bcoo%ia,ndx,mpi_integer,& -!!$ & cootmp%ia,nzbr,idisp,& -!!$ & mpi_integer,icomm,info) -!!$ -!!$ if (info == psb_success_) call mpi_allgatherv(bcoo%ja,ndx,mpi_integer,& -!!$ & cootmp%ja,nzbr,idisp,& -!!$ & mpi_integer,icomm,info) -!!$ -!!$ if (info /= psb_success_) then -!!$ call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') -!!$ goto 9999 -!!$ end if -!!$ call bcoo%free() -!!$ call cootmp%set_nzeros(nzac) -!!$ call cootmp%set_dupl(psb_dupl_add_) -!!$ call p%ac%mv_from(cootmp) -!!$ if(info /= psb_success_) goto 9999 - deallocate(nzbr,idisp,stat=info) if (info /= psb_success_) then diff --git a/mlprec/mld_das_aply.f90 b/mlprec/mld_das_aply.f90 deleted file mode 100644 index ec1ff94b..00000000 --- a/mlprec/mld_das_aply.f90 +++ /dev/null @@ -1,411 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,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. -!!$ -!!$ -! File: mld_das_aply.f90 -! -! Subroutine: mld_das_aply -! Version: real -! -! This routine applies the Additive Schwarz preconditioner by computing -! -! Y = beta*Y + alpha*op(K^(-1))*X, -! where -! - K is the base preconditioner, stored in prec, -! - op(K^(-1)) is K^(-1) or its transpose, according to the value of trans, -! - X and Y are vectors, -! - alpha and beta are scalars. -! -! -! Arguments: -! alpha - real(psb_dpk_), input. -! The scalar alpha. -! prec - type(mld_dbaseprec_type), input. -! The base preconditioner data structure containing the local part -! of the preconditioner K. -! x - real(psb_dpk_), dimension(:), input. -! The local part of the vector X. -! beta - real(psb_dpk_), input. -! The scalar beta. -! y - real(psb_dpk_), dimension(:), input/output. -! The local part of the vector Y. -! desc_data - type(psb_desc_type), input. -! The communication descriptor associated to the matrix to be -! preconditioned. -! trans - character, optional. -! If trans='N','n' then op(K^(-1)) = K^(-1); -! if trans='T','t' then op(K^(-1)) = K^(-T) (transpose of K^(-1)). -! work - real(psb_dpk_), dimension (:), optional, target. -! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data). -! info - integer, output. -! Error code. -! -subroutine mld_das_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - - use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_das_aply - - implicit none - - ! Arguments - type(psb_desc_type),intent(in) :: desc_data - type(mld_dbaseprec_type), intent(in) :: prec - real(psb_dpk_),intent(in) :: x(:) - real(psb_dpk_),intent(inout) :: y(:) - real(psb_dpk_),intent(in) :: alpha,beta - character(len=1) :: trans - real(psb_dpk_),target :: work(:) - integer, intent(out) :: info - - ! Local variables - integer :: n_row,n_col, int_err(5), nrow_d - real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) - integer :: ictxt,np,me,isz, err_act - character(len=20) :: name, ch_err - character :: trans_ - - name='mld_das_aply' - info = psb_success_ - call psb_erractionsave(err_act) - - ictxt = psb_cd_get_context(desc_data) - - call psb_info(ictxt, me, np) - - trans_ = psb_toupper(trans) - - select case(prec%iprcparm(mld_smoother_type_)) - - case(mld_bjac_) - - call mld_sub_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_sub_aply' - goto 9999 - end if - - case(mld_as_) - ! - ! Additive Schwarz preconditioner - ! - - if ((prec%iprcparm(mld_sub_ovr_) == 0).or.(np==1)) then - ! - ! Shortcut: this fixes performance for RAS(0) == BJA - ! - call mld_sub_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_sub_aply' - goto 9999 - end if - - else - ! - ! Overlap > 0 - ! - - n_row = psb_cd_get_local_rows(prec%desc_data) - n_col = psb_cd_get_local_cols(prec%desc_data) - nrow_d = psb_cd_get_local_rows(desc_data) - 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 - - tx(1:nrow_d) = x(1:nrow_d) - tx(nrow_d+1:isz) = dzero - - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (prec%iprcparm(mld_sub_restr_) == psb_halo_) then - call psb_halo(tx,prec%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 (prec%iprcparm(mld_sub_restr_) /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - ! - ! If required, reorder tx according to the row/column permutation of the - ! local extended matrix, stored into the permutation vector prec%perm - ! - if (prec%iprcparm(mld_sub_ren_)>0) then -!!$ call psb_gelp('n',prec%perm,tx,info) - info = 1 - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_gelp' - goto 9999 - end if - endif - - ! - ! Apply to tx the block-Jacobi preconditioner/solver (multiple sweeps of the - ! block-Jacobi solver can be applied at the coarsest level of a multilevel - ! preconditioner). The resulting vector is ty. - ! - call mld_sub_aply(done,prec,tx,dzero,ty,prec%desc_data,trans_,aux,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_bjac_aply' - goto 9999 - end if - - ! - ! Apply to ty the inverse permutation of prec%perm - ! - if (prec%iprcparm(mld_sub_ren_)>0) then -!!$ call psb_gelp('n',prec%invperm,ty,info) - info = 1 - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_gelp' - goto 9999 - end if - endif - - select case (prec%iprcparm(mld_sub_prol_)) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,prec%desc_data,info,& - ! & update=prec%iprcparm(mld_sub_prol_),work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(ty,prec%desc_data,info,& - & update=prec%iprcparm(mld_sub_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 - ! - - select case (prec%iprcparm(mld_sub_prol_)) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(tx,prec%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,prec%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,prec%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 - - ! - ! If required, reorder tx according to the row/column permutation of the - ! local extended matrix, stored into the permutation vector prec%perm - ! - if (prec%iprcparm(mld_sub_ren_)>0) then -!!$ call psb_gelp('n',prec%perm,tx,info) - info = 1 - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_gelp' - goto 9999 - end if - endif - - ! - ! Apply to tx the block-Jacobi preconditioner/solver (multiple sweeps of the - ! block-Jacobi solver can be applied at the coarsest level of a multilevel - ! preconditioner). The resulting vector is ty. - ! - call mld_sub_aply(done,prec,tx,dzero,ty,prec%desc_data,trans_,aux,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_bjac_aply' - goto 9999 - end if - - ! - ! Apply to ty the inverse permutation of prec%perm - ! - if (prec%iprcparm(mld_sub_ren_)>0) then -!!$ call psb_gelp('n',prec%invperm,ty,info) - info = 1 - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_gelp' - goto 9999 - end if - endif - - ! - ! With transpose, we have to do it here - ! - if (prec%iprcparm(mld_sub_restr_) == psb_halo_) then - call psb_ovrl(ty,prec%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 (prec%iprcparm(mld_sub_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 - - ! - ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) - ! - call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - - - 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 - end if - - case default - - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_smoother_type_') - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine mld_das_aply - diff --git a/mlprec/mld_das_bld.f90 b/mlprec/mld_das_bld.f90 deleted file mode 100644 index 15f8f6d8..00000000 --- a/mlprec/mld_das_bld.f90 +++ /dev/null @@ -1,270 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,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. -!!$ -!!$ -! File: mld_das_bld.f90 -! -! Subroutine: mld_das_bld -! Version: real -! -! This routine builds Additive Schwarz (AS) preconditioners. If the AS -! preconditioner is actually the block-Jacobi one, the routine makes only a -! copy of the descriptor of the original matrix and then calls mld_fact_bld -! to perform an LU or ILU factorization of the diagonal blocks of the -! distributed matrix. -! -! -! Arguments: -! a - type(psb_dspmat_type), input. -! The sparse matrix structure containing the local part of the -! matrix to be preconditioned. -! desc_a - type(psb_desc_type), input. -! The communication descriptor of the sparse matrix a. -! p - type(mld_dbaseprec_type), input/output. -! The 'base preconditioner' data structure containing the local -! part of the preconditioner or solver to be built. -! upd - character, input. -! If upd='F' then the preconditioner is built from scratch; -! if upd=T' then the matrix to be preconditioned has the same -! sparsity pattern of a matrix that has been previously -! preconditioned, hence some information is reused in building -! the new preconditioner. -! info - integer, output. -! Error code. -! -subroutine mld_das_bld(a,desc_a,p,upd,info) - - use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_das_bld - - Implicit None - - ! Arguments - type(psb_dspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(in) :: desc_a - type(mld_dbaseprec_type), intent(inout) :: p - character, intent(in) :: upd - integer, intent(out) :: info - - ! Local variables - integer :: ptype,novr - integer :: icomm - Integer :: np,me,nnzero,ictxt, int_err(5),& - & tot_recv, n_row,n_col,nhalo, err_act, data_ - type(psb_dspmat_type) :: blck - integer :: debug_level, debug_unit - character(len=20) :: name, ch_err - - name='mld_as_bld' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - If (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' start ', upd - ictxt = psb_cd_get_context(desc_a) - icomm = psb_cd_get_mpic(desc_a) - - Call psb_info(ictxt, me, np) - - tot_recv=0 - - n_row = psb_cd_get_local_rows(desc_a) - n_col = psb_cd_get_local_cols(desc_a) - nnzero = a%get_nzeros() - nhalo = n_col-n_row - ptype = p%iprcparm(mld_smoother_type_) - novr = p%iprcparm(mld_sub_ovr_) - - select case (ptype) - - case(mld_bjac_) - ! - ! Block Jacobi - ! - data_ = psb_no_comm_ - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Calling desccpy' - if (upd == 'F') then - call psb_cdcpy(desc_a,p%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 mld_fact_bld(a,p,upd,info) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_fact_bld' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - case(mld_as_) - ! - ! Additive Schwarz - ! - if (novr < 0) then - info=psb_err_invalid_ovr_num_ - int_err(1)=novr - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - if ((novr == 0).or.(np == 1)) then - ! - ! Actually, this is just block Jacobi - ! - data_ = psb_no_comm_ - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Calling desccpy' - if (upd == 'F') then - call psb_cdcpy(desc_a,p%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 (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,p%desc_data,info,extype=psb_ovt_asov_) - if(debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' From cdbldext _:',psb_cd_get_local_rows(p%desc_data),& - & psb_cd_get_local_cols(p%desc_data) - - 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,p%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 - - - call mld_fact_bld(a,p,upd,info,blck=blck) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_fact_bld' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case default - - info=psb_err_internal_error_ - ch_err='Invalid ptype' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - - End select - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),'Done' - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then - call psb_error() - return - end if - Return - -End Subroutine mld_das_bld - diff --git a/mlprec/mld_dbaseprec_aply.f90 b/mlprec/mld_dbaseprec_aply.f90 deleted file mode 100644 index 059c62ae..00000000 --- a/mlprec/mld_dbaseprec_aply.f90 +++ /dev/null @@ -1,189 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,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. -!!$ -!!$ -! File: mld_dbaseprec_aply.f90 -! -! Subroutine: mld_dbaseprec_aply -! Version: real -! -! This routine applies a base preconditioner by computing -! -! Y = beta*Y + alpha*op(K^(-1))*X, -! where -! - K is the base preconditioner, stored in prec, -! - op(K^(-1)) is K^(-1) or its transpose, according to the value of trans, -! - X and Y are vectors, -! - alpha and beta are scalars. -! -! The routine is used by mld_dmlprec_aply, to apply the multilevel preconditioners, -! or directly by mld_dprec_aply, to apply the basic one-level preconditioners (diagonal, -! block-Jacobi or additive Schwarz). It also manages the case of no preconditioning. -! -! -! Arguments: -! alpha - real(psb_dpk_), input. -! The scalar alpha. -! prec - type(mld_dbaseprec_type), input. -! The base preconditioner data structure containing the local part -! of the preconditioner K. -! x - real(psb_dpk_), dimension(:), input. -! The local part of the vector X. -! beta - real(psb_dpk_), input. -! The scalar beta. -! y - real(psb_dpk_), dimension(:), input/output. -! The local part of the vector Y. -! desc_data - type(psb_desc_type), input. -! The communication descriptor associated to the matrix to be -! preconditioned. -! trans - character, optional. -! If trans='N','n' then op(K^(-1)) = K^(-1); -! if trans='T','t' then op(K^(-1)) = K^(-T) (transpose of K^(-1)). -! work - real(psb_dpk_), dimension (:), optional, target. -! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data). -! info - integer, output. -! Error code. -! -subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - - use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_dbaseprec_aply - - implicit none - - ! Arguments - type(psb_desc_type),intent(in) :: desc_data - type(mld_dbaseprec_type), intent(in) :: prec - real(psb_dpk_),intent(in) :: x(:) - real(psb_dpk_),intent(inout) :: y(:) - real(psb_dpk_),intent(in) :: alpha,beta - character(len=1) :: trans - real(psb_dpk_),target :: work(:) - integer, intent(out) :: info - - ! Local variables - real(psb_dpk_), pointer :: ww(:) - integer :: ictxt, np, me, err_act - integer :: n_row, int_err(5) - character(len=20) :: name, ch_err - character :: trans_ - - name='mld_dbaseprec_aply' - info = psb_success_ - call psb_erractionsave(err_act) - - ictxt = psb_cd_get_context(desc_data) - - call psb_info(ictxt, me, np) - - trans_= psb_toupper(trans) - select case(trans_) - case('N','T','C') - ! Ok - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - select case(prec%iprcparm(mld_smoother_type_)) - - case(mld_noprec_) - ! - ! No preconditioner - ! - - call psb_geaxpby(alpha,x,beta,y,desc_data,info) - - case(mld_diag_) - ! - ! Diagonal preconditioner - ! - - if (size(work) >= size(x)) then - ww => work - else - allocate(ww(size(x)),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/size(x),0,0,0,0/),a_err='real(psb_dpk_)') - goto 9999 - end if - end if - - n_row = psb_cd_get_local_rows(desc_data) - ww(1:n_row) = x(1:n_row)*prec%d(1:n_row) - call psb_geaxpby(alpha,ww,beta,y,desc_data,info) - - if (size(work) < size(x)) then - deallocate(ww,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') - goto 9999 - end if - end if - - case(mld_bjac_,mld_as_) - ! - ! Additive Schwarz preconditioner (including block-Jacobi as special case) - ! - call mld_as_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_as_aply' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_smoother_type_') - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine mld_dbaseprec_aply - diff --git a/mlprec/mld_dbaseprec_bld.f90 b/mlprec/mld_dbaseprec_bld.f90 deleted file mode 100644 index 8b39afb4..00000000 --- a/mlprec/mld_dbaseprec_bld.f90 +++ /dev/null @@ -1,215 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,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. -!!$ -!!$ -! File: mld_dbaseprec_bld.f90 -! -! Subroutine: mld_dbaseprec_bld -! Version: real -! -! This routine builds a 'base preconditioner' related to a matrix A. -! In a multilevel framework, it is called by mld_mlprec_bld to build the -! base preconditioner at each level. -! -! Details on the base preconditioner to be built are stored in the iprcparm -! field of the base preconditioner data structure (for a description of this -! data structure see mld_prec_type.f90). -! -! -! Arguments: -! a - type(psb_dspmat_type). -! The sparse matrix structure containing the local part of the -! matrix A to be preconditioned. -! desc_a - type(psb_desc_type), input. -! The communication descriptor of a. -! p - type(mld_dbaseprec_type), input/output. -! The 'base preconditioner' data structure containing the local -! part of the preconditioner at the selected level. -! info - integer, output. -! Error code. -! upd - character, input, optional. -! If upd='F' then the base preconditioner is built from -! scratch; if upd=T' then the matrix to be preconditioned -! has the same sparsity pattern of a matrix that has been -! previously preconditioned, hence some information is reused -! in building the new preconditioner. -! -subroutine mld_dbaseprec_bld(a,desc_a,p,info,upd) - - use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_dbaseprec_bld - - Implicit None - - ! Arguments - type(psb_dspmat_type), target :: a - type(psb_desc_type), intent(in), target :: desc_a - type(mld_dbaseprec_type),intent(inout) :: p - integer, intent(out) :: info - character, intent(in), optional :: upd - - ! Local variables - Integer :: err, n_row, n_col,ictxt, me,np,mglob, err_act - character :: iupd - integer :: debug_level, debug_unit - character(len=20) :: name, ch_err - - if (psb_get_errstatus() /= 0) return - name = 'mld_dbaseprec_bld' - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ictxt = psb_cd_get_context(desc_a) - n_row = psb_cd_get_local_rows(desc_a) - n_col = psb_cd_get_local_cols(desc_a) - mglob = psb_cd_get_global_rows(desc_a) - call psb_info(ictxt, me, np) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),' start' - - - if (present(upd)) then - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),'UPD ', upd - if ((psb_toupper(UPD) == 'F').or.(psb_toupper(UPD) == 'T')) then - IUPD=psb_toupper(UPD) - else - IUPD='F' - endif - else - IUPD='F' - endif - - ! - ! Should add check to ensure all procs have the same... - ! - - call mld_check_def(p%iprcparm(mld_smoother_type_),'base_prec',& - & mld_diag_,is_legal_base_prec) - - - call psb_nullify_desc(p%desc_data) - - select case(p%iprcparm(mld_smoother_type_)) - - case (mld_noprec_) - ! No preconditioner - - ! Do nothing - call psb_cdcpy(desc_a,p%desc_data,info) - 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 - - case (mld_diag_) - ! Diagonal preconditioner - - call mld_diag_bld(a,desc_a,p,info) - if(debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ': out of mld_diag_bld' - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_diag_bld' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case(mld_bjac_,mld_as_) - ! Additive Schwarz preconditioners/smoothers - - call mld_check_def(p%iprcparm(mld_sub_ovr_),'overlap',& - & 0,is_legal_n_ovr) - call mld_check_def(p%iprcparm(mld_sub_restr_),'restriction',& - & psb_halo_,is_legal_restrict) - call mld_check_def(p%iprcparm(mld_sub_prol_),'prolongator',& - & psb_none_,is_legal_prolong) - call mld_check_def(p%iprcparm(mld_sub_ren_),'renumbering',& - & mld_renum_none_,is_legal_renum) - call mld_check_def(p%iprcparm(mld_sub_solve_),'fact',& - & mld_ilu_n_,is_legal_ml_fact) - - ! Set parameters for using SuperLU_dist on the local submatrices - if (p%iprcparm(mld_sub_solve_) == mld_sludist_) then - p%iprcparm(mld_sub_ovr_) = 0 - p%iprcparm(mld_smoother_sweeps_) = 1 - end if - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ': Calling mld_as_bld' - - ! Build the local part of the base preconditioner/smoother - call mld_as_bld(a,desc_a,p,iupd,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='mld_as_bld') - goto 9999 - end if - - case default - - info=psb_err_internal_error_ - ch_err='Unknown mld_smoother_type_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - - end select - - p%iprcparm(mld_prec_status_) = mld_prec_built_ - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),': Done' - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine mld_dbaseprec_bld - diff --git a/mlprec/mld_dilu_bld.f90 b/mlprec/mld_dilu_bld.f90 deleted file mode 100644 index 7557a5f7..00000000 --- a/mlprec/mld_dilu_bld.f90 +++ /dev/null @@ -1,287 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,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. -!!$ -!!$ -! File: mld_dilu_bld.f90 -! -! Subroutine: mld_dilu_bld -! Version: real -! -! This routine computes an incomplete LU (ILU) factorization of the diagonal -! blocks of a distributed matrix. This factorization is used to build the -! 'base preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz -! preconditioner) corresponding to a certain level of a multilevel preconditioner. -! -! The following factorizations are available: -! - ILU(k), i.e. ILU factorization with fill-in level k, -! - MILU(k), i.e. modified ILU factorization with fill-in level k, -! - ILU(k,t), i.e. ILU with threshold (i.e. drop tolerance) t and k additional -! entries in each row of the L and U factors with respect to the initial -! sparsity pattern. -! Note that the meaning of k in ILU(k,t) is different from that in ILU(k) and -! MILU(k). -! -! For details on the above factorizations see -! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, -! SIAM, 2003, Chapter 10. -! -! Note that that this routine handles the ILU(0) factorization separately, -! through mld_ilu0_fact, for performance reasons. -! -! -! Arguments: -! a - type(psb_dspmat_type), input. -! The sparse matrix structure containing the local matrix. -! Note that if p%iprcparm(mld_sub_ovr_) > 0, i.e. the -! 'base' Additive Schwarz preconditioner has overlap greater than -! 0, and p%iprcparm(mld_sub_ren_) = 0, i.e. a reordering of the -! matrix has not been performed (see mld_fact_bld), then a contains -! only the 'original' local part of the distributed matrix, -! i.e. the rows of the matrix held by the calling process according -! to the initial data distribution. -! p - type(mld_dbaseprec_type), input/output. -! The 'base preconditioner' data structure. In input, p%iprcparm -! contains information on the type of factorization to be computed. -! In output, p%av(mld_l_pr_) and p%av(mld_u_pr_) contain the -! incomplete L and U factors (without their diagonals), and p%d -! contains the diagonal of the incomplete U factor. For more -! details on p see its description in mld_prec_type.f90. -! info - integer, output. -! Error code. -! blck - type(psb_dspmat_type), input, optional. -! The sparse matrix structure containing the remote rows of the -! distributed matrix, that have been retrieved by mld_as_bld -! to build an Additive Schwarz base preconditioner with overlap -! greater than 0. If the overlap is 0 or the matrix has been reordered -! (see mld_fact_bld), then blck does not contain any row. -! -subroutine mld_dilu_bld(a,p,upd,info,blck) - - use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_dilu_bld - - implicit none - - ! Arguments - type(psb_dspmat_type), intent(in), target :: a - type(mld_dbaseprec_type), intent(inout) :: p - character, intent(in) :: upd - integer, intent(out) :: info - type(psb_dspmat_type), intent(in), optional :: blck - - ! Local Variables - integer :: i, nztota, err_act, n_row, nrow_a - character :: trans, unitd - integer :: debug_level, debug_unit - integer :: ictxt,np,me - character(len=20) :: name, ch_err - - if(psb_get_errstatus().ne.0) return - info=psb_success_ - name='mld_dilu_bld' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = psb_cd_get_context(p%desc_data) - call psb_info(ictxt, me, np) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),' start' - trans = 'N' - unitd = 'U' - - - n_row = psb_cd_get_local_rows(p%desc_data) - - if (psb_toupper(upd) == 'F') then - ! - ! Check the memory available to hold the incomplete L and U factors - ! and allocate it if needed - ! - if (allocated(p%av)) then - if (size(p%av) < mld_bp_ilu_avsz_) then - do i=1, size(p%av) - call p%av(i)%free() - enddo - deallocate(p%av,stat=info) - endif - end if - if (.not.allocated(p%av)) then - allocate(p%av(mld_max_avsz_),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - endif - - nrow_a = a%get_nrows() - nztota = a%get_nzeros() - if (present(blck)) then - nztota = nztota + blck%get_nzeros() - end if - - call p%av(mld_l_pr_)%csall(n_row,n_row,info,nztota) - if (info == psb_success_) call p%av(mld_u_pr_)%csall(n_row,n_row,info,nztota) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if (allocated(p%d)) then - if (size(p%d) < n_row) then - deallocate(p%d) - endif - endif - if (.not.allocated(p%d)) then - allocate(p%d(n_row),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - endif - - - select case(p%iprcparm(mld_sub_solve_)) - - case (mld_ilu_t_) - ! - ! ILU(k,t) - ! - select case(p%iprcparm(mld_sub_fillin_)) - - case(:-1) - ! Error: fill-in <= -1 - call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,p%iprcparm(mld_sub_fillin_),0,0,0/)) - goto 9999 - - case(0:) - ! Fill-in >= 0 - call mld_ilut_fact(p%iprcparm(mld_sub_fillin_),p%rprcparm(mld_sub_iluthrs_),& - & a, p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck) - end select - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_ilut_fact' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case(mld_ilu_n_,mld_milu_n_) - ! - ! ILU(k) and MILU(k) - ! - select case(p%iprcparm(mld_sub_fillin_)) - case(:-1) - ! Error: fill-in <= -1 - call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,p%iprcparm(mld_sub_fillin_),0,0,0/)) - goto 9999 - case(0) - ! Fill-in 0 - ! Separate implementation of ILU(0) for better performance. - ! There seems to be a problem with the separate implementation of MILU(0), - ! contained into mld_ilu0_fact. This must be investigated. For the time being, - ! resort to the implementation of MILU(k) with k=0. - if (p%iprcparm(mld_sub_solve_) == mld_ilu_n_) then - call mld_ilu0_fact(p%iprcparm(mld_sub_solve_),a,p%av(mld_l_pr_),p%av(mld_u_pr_),& - & p%d,info,blck=blck,upd=upd) - else - call mld_iluk_fact(p%iprcparm(mld_sub_fillin_),p%iprcparm(mld_sub_solve_),& - & a,p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck) - endif - case(1:) - ! Fill-in >= 1 - ! The same routine implements both ILU(k) and MILU(k) - call mld_iluk_fact(p%iprcparm(mld_sub_fillin_),p%iprcparm(mld_sub_solve_),& - & a,p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck) - end select - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_iluk_fact' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case default - ! If we end up here, something was wrong up in the call chain. - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - - end select - else - ! Here we should add checks for reuse of L and U. - ! For the time being just throw an error. - info = 31 - call psb_errpush(info, name, i_err=(/3,0,0,0,0/),a_err=upd) - goto 9999 - - ! - ! What is an update of a factorization?? - ! A first attempt could be to reuse EXACTLY the existing indices - ! as if it was an ILU(0) (since, effectively, the sparsity pattern - ! should not grow beyond what is already there). - ! - call mld_ilu0_fact(p%iprcparm(mld_sub_solve_),a,& - & p%av(mld_l_pr_),p%av(mld_u_pr_),& - & p%d,info,blck=blck,upd=upd) - - - end if - - call p%av(mld_l_pr_)%set_asb() - call p%av(mld_l_pr_)%trim() - call p%av(mld_u_pr_)%set_asb() - call p%av(mld_u_pr_)%trim() - - 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.eq.psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine mld_dilu_bld - - diff --git a/mlprec/mld_move_alloc_mod.f90 b/mlprec/mld_move_alloc_mod.f90 index 51cef827..04957a4b 100644 --- a/mlprec/mld_move_alloc_mod.f90 +++ b/mlprec/mld_move_alloc_mod.f90 @@ -71,12 +71,12 @@ contains call mld_precfree(b,info) if (info == psb_success_) call psb_move_alloc(a%iprcparm,b%iprcparm,info) - if (info == psb_success_) call psb_move_alloc(a%rprcparm,b%rprcparm,info) - if (info == psb_success_) call psb_move_alloc(a%desc_data,b%desc_data,info) - if (info == psb_success_) call psb_move_alloc(a%perm,b%perm,info) - if (info == psb_success_) call psb_move_alloc(a%invperm,b%invperm,info) - if (info == psb_success_) call psb_move_alloc(a%d,b%d,info) - call move_alloc(a%av,b%av) +!!$ if (info == psb_success_) call psb_move_alloc(a%rprcparm,b%rprcparm,info) +!!$ if (info == psb_success_) call psb_move_alloc(a%desc_data,b%desc_data,info) +!!$ if (info == psb_success_) call psb_move_alloc(a%perm,b%perm,info) +!!$ if (info == psb_success_) call psb_move_alloc(a%invperm,b%invperm,info) +!!$ if (info == psb_success_) call psb_move_alloc(a%d,b%d,info) +!!$ call move_alloc(a%av,b%av) if (info /= psb_success_) then write(0,*) 'Error in baseprec_:transfer',info end if diff --git a/mlprec/mld_s_as_smoother.f03 b/mlprec/mld_s_as_smoother.f03 new file mode 100644 index 00000000..2e1c4992 --- /dev/null +++ b/mlprec/mld_s_as_smoother.f03 @@ -0,0 +1,874 @@ +!!$ +!!$ +!!$ 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. +!!$ +!!$ +! +! +! +! +! +! +module mld_s_as_smoother + + use mld_s_prec_type + + type, extends(mld_s_base_smoother_type) :: mld_s_as_smoother_type + ! The local solver component is inherited from the + ! parent type. + ! class(mld_s_base_solver_type), allocatable :: sv + ! + type(psb_sspmat_type) :: nd + type(psb_desc_type) :: desc_data + integer :: novr, restr, prol + contains + procedure, pass(sm) :: build => s_as_smoother_bld + procedure, pass(sm) :: apply => 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) :: descr => s_as_smoother_descr + procedure, pass(sm) :: sizeof => s_as_smoother_sizeof + 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 + + character(len=6), parameter, private :: & + & restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/) + character(len=12), parameter, private :: & + & prolong_names(0:3)=(/'none ','sum ','average ','square root'/) + + +contains + + subroutine s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + use psb_sparse_mod + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_as_smoother_type), intent(in) :: sm + real(psb_spk_),intent(in) :: 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_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T','C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + if (.not.allocated(sm%sv)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + end if + + + n_row = psb_cd_get_local_rows(sm%desc_data) + n_col = psb_cd_get_local_cols(sm%desc_data) + nrow_d = psb_cd_get_local_rows(desc_data) + 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,tx,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) + + use psb_sparse_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 + ! Local variables + type(psb_sspmat_type) :: blck, atmp + integer :: n_row,n_col, nrow_a, nhalo, novr, data_ + 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 = psb_cd_get_context(desc_a) + 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 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 _:',psb_cd_get_local_rows(sm%desc_data),& + & psb_cd_get_local_cols(sm%desc_data) + + 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) + + nrow_a = a%get_nrows() + n_row = psb_cd_get_local_rows(sm%desc_data) + n_col = psb_cd_get_local_cols(sm%desc_data) + + 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_) call sm%nd%cscnv(info,& + & type='csr',dupl=psb_dupl_add_) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4') + goto 9999 + end if + + 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_sparse_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) +!!$ else +!!$ write(0,*) trim(name),' Missing component, not setting!' +!!$ info = 1121 + end if + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine s_as_smoother_seti + + subroutine s_as_smoother_setc(sm,what,val,info) + + use psb_sparse_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 + + 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_setc + + subroutine s_as_smoother_setr(sm,what,val,info) + + use psb_sparse_mod + + 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_sparse_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_ + + + + 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 s_as_smoother_free + + subroutine s_as_smoother_descr(sm,info,iout) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_as_smoother_type), intent(in) :: sm + integer, intent(out) :: info + integer, intent(in), optional :: iout + + ! Local variables + integer :: err_act + integer :: ictxt, me, np + character(len=20), parameter :: name='mld_s_as_smoother_descr' + integer :: iout_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + endif + + write(iout_,*) ' Additive Schwarz with ',& + & sm%novr, ' overlap layers.' + write(iout_,*) ' Restrictor: ',restrict_names(sm%restr) + write(iout_,*) ' Prolongator: ',prolong_names(sm%prol) + write(iout_,*) ' Local solver:' + if (allocated(sm%sv)) then + call sm%sv%descr(info,iout_) + 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_descr + + function s_as_smoother_sizeof(sm) result(val) + use psb_sparse_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 + +end module mld_s_as_smoother diff --git a/mlprec/mld_s_diag_solver.f03 b/mlprec/mld_s_diag_solver.f03 new file mode 100644 index 00000000..046d1580 --- /dev/null +++ b/mlprec/mld_s_diag_solver.f03 @@ -0,0 +1,466 @@ +!!$ +!!$ +!!$ 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. +!!$ +!!$ +! +! +! +! +! +! + +module mld_s_diag_solver + + use mld_s_prec_type + + type, extends(mld_s_base_solver_type) :: mld_s_diag_solver_type + real(psb_spk_), allocatable :: d(:) + contains + procedure, pass(sv) :: build => s_diag_solver_bld + procedure, pass(sv) :: apply => s_diag_solver_apply + procedure, pass(sv) :: free => s_diag_solver_free + procedure, pass(sv) :: seti => s_diag_solver_seti + procedure, pass(sv) :: setc => s_diag_solver_setc + procedure, pass(sv) :: setr => s_diag_solver_setr + procedure, pass(sv) :: descr => s_diag_solver_descr + procedure, pass(sv) :: sizeof => s_diag_solver_sizeof + end type mld_s_diag_solver_type + + + private :: s_diag_solver_bld, s_diag_solver_apply, & + & s_diag_solver_free, s_diag_solver_seti, & + & s_diag_solver_setc, s_diag_solver_setr,& + & s_diag_solver_descr, s_diag_solver_sizeof + + +contains + + subroutine s_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + use psb_sparse_mod + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_diag_solver_type), intent(in) :: sv + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_spk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + + integer :: n_row,n_col + real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='s_diag_solver_apply' + + call psb_erractionsave(err_act) + + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T','C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = psb_cd_get_local_rows(desc_data) + n_col = psb_cd_get_local_cols(desc_data) + + if (beta == dzero) then + + if (alpha == dzero) then + y(1:n_row) = dzero + else if (alpha == done) then + do i=1, n_row + y(i) = sv%d(i) * x(i) + end do + else if (alpha == -done) then + do i=1, n_row + y(i) = -sv%d(i) * x(i) + end do + else + do i=1, n_row + y(i) = alpha * sv%d(i) * x(i) + end do + end if + + else if (beta == done) then + + if (alpha == dzero) then + !y(1:n_row) = dzero + else if (alpha == done) then + do i=1, n_row + y(i) = sv%d(i) * x(i) + y(i) + end do + else if (alpha == -done) then + do i=1, n_row + y(i) = -sv%d(i) * x(i) + y(i) + end do + else + do i=1, n_row + y(i) = alpha * sv%d(i) * x(i) + y(i) + end do + end if + + else if (beta == -done) then + + if (alpha == dzero) then + y(1:n_row) = -y(1:n_row) + else if (alpha == done) then + do i=1, n_row + y(i) = sv%d(i) * x(i) - y(i) + end do + else if (alpha == -done) then + do i=1, n_row + y(i) = -sv%d(i) * x(i) - y(i) + end do + else + do i=1, n_row + y(i) = alpha * sv%d(i) * x(i) - y(i) + end do + end if + + else + + if (alpha == dzero) then + y(1:n_row) = beta *y(1:n_row) + else if (alpha == done) then + do i=1, n_row + y(i) = sv%d(i) * x(i) + beta*y(i) + end do + else if (alpha == -done) then + do i=1, n_row + y(i) = -sv%d(i) * x(i) + beta*y(i) + end do + else + do i=1, n_row + y(i) = alpha * sv%d(i) * x(i) + beta*y(i) + end do + end if + + 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_diag_solver_apply + + subroutine s_diag_solver_bld(a,desc_a,sv,upd,info,b) + + use psb_sparse_mod + + Implicit None + + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_s_diag_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer, intent(out) :: info + type(psb_sspmat_type), intent(in), target, optional :: b + ! Local variables + integer :: n_row,n_col, nrow_a, nztota + real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='s_diag_solver_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = psb_cd_get_local_rows(desc_a) + nrow_a = a%get_nrows() + if (allocated(sv%d)) then + if (size(sv%d) < n_row) then + deallocate(sv%d) + endif + endif + if (.not.allocated(sv%d)) then + allocate(sv%d(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + endif + + call a%get_diag(sv%d,info) + if (present(b)) then + if (info == psb_success_) call b%get_diag(sv%d(nrow_a+1:), info) + end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='get_diag') + goto 9999 + end if + + do i=1,n_row + if (sv%d(i) == dzero) then + sv%d(i) = done + else + sv%d(i) = done/sv%d(i) + end if + end do + + + 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_diag_solver_bld + + + subroutine s_diag_solver_seti(sv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_diag_solver_type), intent(inout) :: sv + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='s_diag_solver_seti' + + info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ +!!$ select case(what) +!!$ case(mld_sub_solve_) +!!$ sv%fact_type = val +!!$ case(mld_sub_fillin_) +!!$ sv%fill_in = val +!!$ case default +!!$ write(0,*) name,': Error: invalid WHAT' +!!$ info = -2 +!!$ end select +!!$ +!!$ call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine s_diag_solver_seti + + subroutine s_diag_solver_setc(sv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_diag_solver_type), intent(inout) :: sv + integer, intent(in) :: what + character(len=*), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, ival + character(len=20) :: name='s_diag_solver_setc' + + info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ +!!$ +!!$ call mld_stringval(val,ival,info) +!!$ if (info == psb_success_) call sv%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 s_diag_solver_setc + + subroutine s_diag_solver_setr(sv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_diag_solver_type), intent(inout) :: sv + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='s_diag_solver_setr' + + info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ +!!$ select case(what) +!!$ case(mld_sub_iluthrs_) +!!$ sv%thresh = val +!!$ case default +!!$ write(0,*) name,': Error: invalid WHAT' +!!$ info = -2 +!!$ goto 9999 +!!$ end select +!!$ +!!$ call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine s_diag_solver_setr + + subroutine s_diag_solver_free(sv,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_diag_solver_type), intent(inout) :: sv + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='s_diag_solver_free' + + call psb_erractionsave(err_act) + info = psb_success_ + + if (allocated(sv%d)) then + deallocate(sv%d,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + 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_diag_solver_free + + subroutine s_diag_solver_descr(sv,info,iout) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_diag_solver_type), intent(in) :: sv + integer, intent(out) :: info + integer, intent(in), optional :: iout + + ! Local variables + integer :: err_act + integer :: ictxt, me, np + character(len=20), parameter :: name='mld_s_diag_solver_descr' + integer :: iout_ + + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + endif + + write(iout_,*) ' Diagonal local solver ' + + return + + end subroutine s_diag_solver_descr + + function s_diag_solver_sizeof(sv) result(val) + use psb_sparse_mod + implicit none + ! Arguments + class(mld_s_diag_solver_type), intent(in) :: sv + integer(psb_long_int_k_) :: val + integer :: i + + val = 0 + if (allocated(sv%d)) val = val + psb_sizeof_sp * size(sv%d) + + return + end function s_diag_solver_sizeof + +end module mld_s_diag_solver diff --git a/mlprec/mld_s_ilu_solver.f03 b/mlprec/mld_s_ilu_solver.f03 new file mode 100644 index 00000000..cd764e4d --- /dev/null +++ b/mlprec/mld_s_ilu_solver.f03 @@ -0,0 +1,606 @@ +!!$ +!!$ +!!$ 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. +!!$ +!!$ +! +! +! +! +! +! + +module mld_s_ilu_solver + + use mld_s_prec_type + + type, extends(mld_s_base_solver_type) :: mld_s_ilu_solver_type + type(psb_sspmat_type) :: l, u + real(psb_spk_), allocatable :: d(:) + integer :: fact_type, fill_in + real(psb_spk_) :: thresh + contains + procedure, pass(sv) :: build => s_ilu_solver_bld + procedure, pass(sv) :: apply => s_ilu_solver_apply + procedure, pass(sv) :: free => s_ilu_solver_free + procedure, pass(sv) :: seti => s_ilu_solver_seti + procedure, pass(sv) :: setc => s_ilu_solver_setc + procedure, pass(sv) :: setr => s_ilu_solver_setr + procedure, pass(sv) :: descr => s_ilu_solver_descr + procedure, pass(sv) :: sizeof => s_ilu_solver_sizeof + end type mld_s_ilu_solver_type + + + private :: s_ilu_solver_bld, s_ilu_solver_apply, & + & s_ilu_solver_free, s_ilu_solver_seti, & + & s_ilu_solver_setc, s_ilu_solver_setr,& + & s_ilu_solver_descr, s_ilu_solver_sizeof + + + interface mld_ilu0_fact + subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck,upd) + use psb_sparse_mod, only : psb_sspmat_type, psb_spk_ + integer, intent(in) :: ialg + integer, intent(out) :: info + type(psb_sspmat_type),intent(in) :: a + type(psb_sspmat_type),intent(inout) :: l,u + type(psb_sspmat_type),intent(in), optional, target :: blck + character, intent(in), optional :: upd + real(psb_spk_), intent(inout) :: d(:) + end subroutine mld_silu0_fact + end interface + + interface mld_iluk_fact + subroutine mld_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) + use psb_sparse_mod, only : psb_sspmat_type, psb_spk_ + integer, intent(in) :: fill_in,ialg + integer, intent(out) :: info + type(psb_sspmat_type),intent(in) :: a + type(psb_sspmat_type),intent(inout) :: l,u + type(psb_sspmat_type),intent(in), optional, target :: blck + real(psb_spk_), intent(inout) :: d(:) + end subroutine mld_siluk_fact + end interface + + interface mld_ilut_fact + subroutine mld_silut_fact(fill_in,thres,a,l,u,d,info,blck) + use psb_sparse_mod, only : psb_sspmat_type, psb_spk_ + integer, intent(in) :: fill_in + real(psb_spk_), intent(in) :: thres + integer, intent(out) :: info + type(psb_sspmat_type),intent(in) :: a + type(psb_sspmat_type),intent(inout) :: l,u + type(psb_sspmat_type),intent(in), optional, target :: blck + real(psb_spk_), intent(inout) :: d(:) + end subroutine mld_silut_fact + end interface + + character(len=15), parameter, private :: & + & fact_names(0:4)=(/'none ','DIAG ?? ',& + & 'ILU(n) ',& + & 'MILU(n) ','ILU(t,n) '/) + + +contains + + subroutine s_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + use psb_sparse_mod + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_ilu_solver_type), intent(in) :: sv + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_spk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + + integer :: n_row,n_col + real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_ilu_solver_apply' + + call psb_erractionsave(err_act) + + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T','C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = psb_cd_get_local_rows(desc_data) + n_col = psb_cd_get_local_cols(desc_data) + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + + select case(trans_) + case('N') + call psb_spsm(sone,sv%l,x,szero,ww,desc_data,info,& + & trans=trans_,scale='L',diag=sv%d,choice=psb_none_,work=aux) + + if (info == psb_success_) call psb_spsm(alpha,sv%u,ww,beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) + + case('T','C') + call psb_spsm(sone,sv%u,x,szero,ww,desc_data,info,& + & trans=trans_,scale='L',diag=sv%d,choice=psb_none_,work=aux) + if (info == psb_success_) call psb_spsm(alpha,sv%l,ww,beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) + case default + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid TRANS in ILU subsolve') + goto 9999 + end select + + + if (info /= psb_success_) then + + call psb_errpush(psb_err_internal_error_,name,a_err='Error in subsolve') + goto 9999 + endif + + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + 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_ilu_solver_apply + + subroutine s_ilu_solver_bld(a,desc_a,sv,upd,info,b) + + use psb_sparse_mod + + Implicit None + + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_s_ilu_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer, intent(out) :: info + type(psb_sspmat_type), intent(in), target, optional :: b + ! Local variables + integer :: n_row,n_col, nrow_a, nztota + real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + integer :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='d_ilu_solver_bld', ch_err + + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = psb_cd_get_context(desc_a) + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = psb_cd_get_local_rows(desc_a) + + if (psb_toupper(upd) == 'F') then + nrow_a = a%get_nrows() + nztota = a%get_nzeros() + if (present(b)) then + nztota = nztota + b%get_nzeros() + end if + + call sv%l%csall(n_row,n_row,info,nztota) + if (info == psb_success_) call sv%u%csall(n_row,n_row,info,nztota) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_all' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (allocated(sv%d)) then + if (size(sv%d) < n_row) then + deallocate(sv%d) + endif + endif + if (.not.allocated(sv%d)) then + allocate(sv%d(n_row),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + endif + + + select case(sv%fact_type) + + case (mld_ilu_t_) + ! + ! ILU(k,t) + ! + select case(sv%fill_in) + + case(:-1) + ! Error: fill-in <= -1 + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,sv%fill_in,0,0,0/)) + goto 9999 + + case(0:) + ! Fill-in >= 0 + call mld_ilut_fact(sv%fill_in,sv%thresh,& + & a, sv%l,sv%u,sv%d,info,blck=b) + end select + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='mld_ilut_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case(mld_ilu_n_,mld_milu_n_) + ! + ! ILU(k) and MILU(k) + ! + select case(sv%fill_in) + case(:-1) + ! Error: fill-in <= -1 + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,sv%fill_in,0,0,0/)) + goto 9999 + case(0) + ! Fill-in 0 + ! Separate implementation of ILU(0) for better performance. + ! There seems to be a problem with the separate implementation of MILU(0), + ! contained into mld_ilu0_fact. This must be investigated. For the time being, + ! resort to the implementation of MILU(k) with k=0. + if (sv%fact_type == mld_ilu_n_) then + call mld_ilu0_fact(sv%fact_type,a,sv%l,sv%u,& + & sv%d,info,blck=b,upd=upd) + else + call mld_iluk_fact(sv%fill_in,sv%fact_type,& + & a,sv%l,sv%u,sv%d,info,blck=b) + endif + case(1:) + ! Fill-in >= 1 + ! The same routine implements both ILU(k) and MILU(k) + call mld_iluk_fact(sv%fill_in,sv%fact_type,& + & a,sv%l,sv%u,sv%d,info,blck=b) + end select + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='mld_iluk_fact' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + case default + ! If we end up here, something was wrong up in the call chain. + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + + end select + else + ! Here we should add checks for reuse of L and U. + ! For the time being just throw an error. + info = 31 + call psb_errpush(info, name, i_err=(/3,0,0,0,0/),a_err=upd) + goto 9999 + + ! + ! What is an update of a factorization?? + ! A first attempt could be to reuse EXACTLY the existing indices + ! as if it was an ILU(0) (since, effectively, the sparsity pattern + ! should not grow beyond what is already there). + ! + call mld_ilu0_fact(sv%fact_type,a,& + & sv%l,sv%u,& + & sv%d,info,blck=b,upd=upd) + + end if + + call sv%l%set_asb() + call sv%l%trim() + call sv%u%set_asb() + call sv%u%trim() + + 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_ilu_solver_bld + + + subroutine s_ilu_solver_seti(sv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_ilu_solver_type), intent(inout) :: sv + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_ilu_solver_seti' + + info = psb_success_ + call psb_erractionsave(err_act) + + select case(what) + case(mld_sub_solve_) + sv%fact_type = val + case(mld_sub_fillin_) + sv%fill_in = val + case default +!!$ write(0,*) name,': Error: invalid WHAT' +!!$ info = -2 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine s_ilu_solver_seti + + subroutine s_ilu_solver_setc(sv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_ilu_solver_type), intent(inout) :: sv + integer, intent(in) :: what + character(len=*), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act, ival + character(len=20) :: name='d_ilu_solver_setc' + + info = psb_success_ + call psb_erractionsave(err_act) + + + call mld_stringval(val,ival,info) + if (info == psb_success_) call sv%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 s_ilu_solver_setc + + subroutine s_ilu_solver_setr(sv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_ilu_solver_type), intent(inout) :: sv + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_ilu_solver_setr' + + call psb_erractionsave(err_act) + info = psb_success_ + + select case(what) + case(mld_sub_iluthrs_) + sv%thresh = val + case default +!!$ write(0,*) name,': Error: invalid WHAT' +!!$ info = -2 +!!$ goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine s_ilu_solver_setr + + subroutine s_ilu_solver_free(sv,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_ilu_solver_type), intent(inout) :: sv + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_ilu_solver_free' + + call psb_erractionsave(err_act) + info = psb_success_ + + if (allocated(sv%d)) then + deallocate(sv%d,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + end if + call sv%l%free() + call sv%u%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 s_ilu_solver_free + + subroutine s_ilu_solver_descr(sv,info,iout) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_ilu_solver_type), intent(in) :: sv + integer, intent(out) :: info + integer, intent(in), optional :: iout + + ! Local variables + integer :: err_act + integer :: ictxt, me, np + character(len=20), parameter :: name='mld_s_ilu_solver_descr' + integer :: iout_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + endif + + write(iout_,*) ' Incomplete factorization solver: ',& + & fact_names(sv%fact_type) + select case(sv%fact_type) + case(mld_ilu_n_,mld_milu_n_) + write(iout_,*) ' Fill level:',sv%fill_in + case(mld_ilu_t_) + write(iout_,*) ' Fill level:',sv%fill_in + write(iout_,*) ' Fill threshold :',sv%thresh + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine s_ilu_solver_descr + + function s_ilu_solver_sizeof(sv) result(val) + use psb_sparse_mod + implicit none + ! Arguments + class(mld_s_ilu_solver_type), intent(in) :: sv + integer(psb_long_int_k_) :: val + integer :: i + + val = 2*psb_sizeof_int + psb_sizeof_sp + if (allocated(sv%d)) val = val + psb_sizeof_sp * size(sv%d) + val = val + psb_sizeof(sv%l) + val = val + psb_sizeof(sv%u) + + return + end function s_ilu_solver_sizeof + +end module mld_s_ilu_solver diff --git a/mlprec/mld_s_prec_type.f03 b/mlprec/mld_s_prec_type.f03 new file mode 100644 index 00000000..81554cc9 --- /dev/null +++ b/mlprec/mld_s_prec_type.f03 @@ -0,0 +1,1406 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) +!!$ +!!$ (C) Copyright 2008,2009,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. +!!$ +!!$ +! File: mld_prec_type.f90 +! +! Module: mld_prec_type +! +! This module defines: +! - the mld_prec_type data structure containing the preconditioner and related +! data structures; +! - integer constants defining the preconditioner; +! - character constants describing the preconditioner (used by the routines +! printing out a preconditioner description); +! - the interfaces to the routines for the management of the preconditioner +! data structure (see below). +! +! It contains routines for +! - converting character constants defining the preconditioner into integer +! constants; +! - checking if the preconditioner is correctly defined; +! - printing a description of the preconditioner; +! - deallocating the preconditioner data structure. +! + +module mld_s_prec_type + + use mld_base_prec_type + ! + ! Type: mld_Tprec_type. + ! + ! It is the data type containing all the information about the multilevel + ! preconditioner (here and in the following 'T' denotes 'd', 's', 'c' and + ! 'z', according to the real/complex, single/double precision version of + ! MLD2P4). It consists of an array of 'one-level' intermediate data structures + ! of type mld_Tonelev_type, each containing the information needed to apply + ! the smoothing and the coarse-space correction at a generic level. + ! + ! type mld_Tprec_type + ! type(mld_Tonelev_type), allocatable :: precv(:) + ! end type mld_Tprec_type + ! + ! Note that the levels are numbered in increasing order starting from + ! the finest one and the number of levels is given by size(precv(:)). + ! + ! + ! Type: mld_Tonelev_type. + ! + ! It is the data type containing the necessary items for the current + ! level (essentially, the base preconditioner, the current-level matrix + ! and the restriction and prolongation operators). + ! + ! type mld_Tonelev_type + ! type(mld_Tbaseprec_type) :: prec + ! integer, allocatable :: iprcparm(:) + ! real(psb_Tpk_), allocatable :: rprcparm(:) + ! type(psb_Tspmat_type) :: ac + ! type(psb_desc_type) :: desc_ac + ! type(psb_Tspmat_type), pointer :: base_a => null() + ! type(psb_desc_type), pointer :: base_desc => null() + ! type(psb_Tlinmap_type) :: map + ! end type mld_Tonelev_type + ! + ! Note that psb_Tpk denotes the kind of the real data type to be chosen + ! according to single/double precision version of MLD2P4. + ! + ! prec - type(mld_Tbaseprec_type). + ! The current level preconditioner (aka smoother). + ! iprcparm - integer, dimension(:), allocatable. + ! The integer parameters defining the multilevel strategy. + ! rprcparm - real(psb_Ypk_), dimension(:), allocatable. + ! The real parameters defining the multilevel strategy. + ! ac - The local part of the current-level matrix, built by + ! coarsening the previous-level matrix. + ! desc_ac - type(psb_desc_type). + ! The communication descriptor associated to the matrix + ! stored in ac. + ! base_a - type(psb_zspmat_type), pointer. + ! Pointer (really a pointer!) to the local part of the current + ! matrix (so we have a unified treatment of residuals). + ! We need this to avoid passing explicitly the current matrix + ! to the routine which applies the preconditioner. + ! base_desc - type(psb_desc_type), pointer. + ! Pointer to the communication descriptor associated to the + ! matrix pointed by base_a. + ! map - Stores the maps (restriction and prolongation) between the + ! vector spaces associated to the index spaces of the previous + ! and current levels. + ! + ! + ! Type: mld_Tbaseprec_type. + ! + ! It holds the smoother (base preconditioner) at a single level. + ! + ! type mld_Tbaseprec_type + ! type(psb_Tspmat_type), allocatable :: av(:) + ! IntrType(psb_Tpk_), allocatable :: d(:) + ! type(psb_desc_type) :: desc_data + ! integer, allocatable :: iprcparm(:) + ! real(psb_Tpk_), allocatable :: rprcparm(:) + ! integer, allocatable :: perm(:), invperm(:) + ! end type mld_sbaseprec_type + ! + ! Note that IntrType denotes the real or complex data type, and psb_Tpk denotes + ! the kind of the real or complex type, according to the real/complex, single/double + ! precision version of MLD2P4. + ! + ! av - type(psb_Tspmat_type), dimension(:), allocatable(:). + ! The sparse matrices needed to apply the preconditioner at + ! the current level ilev. + ! av(mld_l_pr_) - The L factor of the ILU factorization of the local + ! diagonal block of the current-level matrix A(ilev). + ! av(mld_u_pr_) - The U factor of the ILU factorization of the local + ! diagonal block of A(ilev), except its diagonal entries + ! (stored in d). + ! av(mld_ap_nd_) - The entries of the local part of A(ilev) outside + ! the diagonal block, for block-Jacobi sweeps. + ! d - real/complex(psb_Tpk_), dimension(:), allocatable. + ! The diagonal entries of the U factor in the ILU factorization + ! of A(ilev). + ! desc_data - type(psb_desc_type). + ! The communication descriptor associated to the base preconditioner, + ! i.e. to the sparse matrices needed to apply the base preconditioner + ! at the current level. + ! iprcparm - integer, dimension(:), allocatable. + ! The integer parameters defining the base preconditioner K(ilev) + ! (the iprcparm entries and values are specified below). + ! rprcparm - real(psb_Tpk_), dimension(:), allocatable. + ! The real parameters defining the base preconditioner K(ilev) + ! (the rprcparm entries and values are specified below). + ! perm - integer, dimension(:), allocatable. + ! The row and column permutations applied to the local part of + ! A(ilev) (defined only if iprcparm(mld_sub_ren_)>0). + ! invperm - integer, dimension(:), allocatable. + ! The inverse of the permutation stored in perm. + ! + ! Note that when the LU factorization of the (local part of the) matrix A(ilev) is + ! computed instead of the ILU one, by using UMFPACK, SuperLU or SuperLU_dist, the + ! corresponding L and U factors are stored in data structures provided by those + ! packages and pointed by prec%iprcparm(mld_umf_ptr), prec%iprcparm(mld_slu_ptr) + ! or prec%iprcparm(mld_slud_ptr). + ! + + type mld_s_base_solver_type + contains + procedure, pass(sv) :: build => s_base_solver_bld + procedure, pass(sv) :: apply => s_base_solver_apply + procedure, pass(sv) :: free => s_base_solver_free + procedure, pass(sv) :: seti => s_base_solver_seti + procedure, pass(sv) :: setc => s_base_solver_setc + procedure, pass(sv) :: setr => s_base_solver_setr + generic, public :: set => seti, setc, setr + procedure, pass(sv) :: default => s_base_solver_default + procedure, pass(sv) :: descr => s_base_solver_descr + procedure, pass(sv) :: sizeof => s_base_solver_sizeof + end type mld_s_base_solver_type + + type mld_s_base_smoother_type + class(mld_s_base_solver_type), allocatable :: sv + contains + procedure, pass(sm) :: build => s_base_smoother_bld + procedure, pass(sm) :: apply => s_base_smoother_apply + procedure, pass(sm) :: free => s_base_smoother_free + procedure, pass(sm) :: seti => s_base_smoother_seti + procedure, pass(sm) :: setc => s_base_smoother_setc + procedure, pass(sm) :: setr => s_base_smoother_setr + generic, public :: set => seti, setc, setr + procedure, pass(sm) :: default => s_base_smoother_default + procedure, pass(sm) :: descr => s_base_smoother_descr + procedure, pass(sm) :: sizeof => s_base_smoother_sizeof + end type mld_s_base_smoother_type + + type, extends(psb_s_base_prec_type) :: mld_sbaseprec_type + integer, allocatable :: iprcparm(:) + real(psb_spk_), allocatable :: rprcparm(:) + end type mld_sbaseprec_type + + type mld_sonelev_type + class(mld_s_base_smoother_type), allocatable :: sm + integer :: sweeps, sweeps_pre, sweeps_post + type(mld_sbaseprec_type) :: prec + integer, allocatable :: iprcparm(:) + real(psb_spk_), allocatable :: rprcparm(:) + type(psb_sspmat_type) :: ac + type(psb_desc_type) :: desc_ac + type(psb_sspmat_type), pointer :: base_a => null() + type(psb_desc_type), pointer :: base_desc => null() + type(psb_slinmap_type) :: map + contains + procedure, pass(lv) :: seti => s_base_onelev_seti + procedure, pass(lv) :: setr => s_base_onelev_setr + procedure, pass(lv) :: setc => s_base_onelev_setc + generic, public :: set => seti, setr, setc + end type mld_sonelev_type + + type, extends(psb_sprec_type) :: mld_sprec_type + integer :: ictxt + type(mld_sonelev_type), allocatable :: precv(:) + contains + procedure, pass(prec) :: s_apply2v => mld_s_apply2v + procedure, pass(prec) :: s_apply1v => mld_s_apply1v + end type mld_sprec_type + + private :: s_base_solver_bld, s_base_solver_apply, & + & s_base_solver_free, s_base_solver_seti, & + & s_base_solver_setc, s_base_solver_setr, & + & s_base_solver_descr, s_base_solver_sizeof, & + & s_base_solver_default, & + & s_base_smoother_bld, s_base_smoother_apply, & + & s_base_smoother_free, s_base_smoother_seti, & + & s_base_smoother_setc, s_base_smoother_setr,& + & s_base_smoother_descr, s_base_smoother_sizeof, & + & s_base_smoother_default + + + ! + ! Interfaces to routines for checking the definition of the preconditioner, + ! for printing its description and for deallocating its data structure + ! + + interface mld_precfree + module procedure mld_sbase_precfree, mld_s_onelev_precfree, mld_sprec_free + end interface + + interface mld_nullify_baseprec + module procedure mld_nullify_dbaseprec + end interface + + interface mld_nullify_onelevprec + module procedure mld_nullify_d_onelevprec + end interface + + interface mld_precdescr + module procedure mld_sfile_prec_descr + end interface + + interface mld_sizeof + module procedure mld_sprec_sizeof, mld_sbaseprec_sizeof, mld_s_onelev_prec_sizeof + end interface + + interface mld_precaply + subroutine mld_sprecaply(prec,x,y,desc_data,info,trans,work) + use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ + import mld_sprec_type + type(psb_desc_type),intent(in) :: desc_data + type(mld_sprec_type), intent(in) :: prec + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + end subroutine mld_sprecaply + subroutine mld_sprecaply1(prec,x,desc_data,info,trans) + use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ + import mld_sprec_type + type(psb_desc_type),intent(in) :: desc_data + type(mld_sprec_type), intent(in) :: prec + real(psb_spk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + end subroutine mld_sprecaply1 + end interface + +contains + ! + ! Function returning the size of the mld_prec_type data structure + ! + + function mld_sprec_sizeof(prec) result(val) + use psb_sparse_mod + implicit none + type(mld_sprec_type), intent(in) :: prec + integer(psb_long_int_k_) :: val + integer :: i + val = 0 + val = val + psb_sizeof_int + if (allocated(prec%precv)) then + do i=1, size(prec%precv) + val = val + mld_sizeof(prec%precv(i)) + end do + end if + end function mld_sprec_sizeof + + function mld_sbaseprec_sizeof(prec) result(val) + implicit none + type(mld_sbaseprec_type), intent(in) :: prec + integer(psb_long_int_k_) :: val + integer :: i + + val = 0 + if (allocated(prec%iprcparm)) then + val = val + psb_sizeof_int * size(prec%iprcparm) + if (prec%iprcparm(mld_prec_status_) == mld_prec_built_) then + select case(prec%iprcparm(mld_sub_solve_)) + case(mld_ilu_n_,mld_ilu_t_) + ! do nothing + case(mld_slu_) + case(mld_umf_) + case(mld_sludist_) + case default + end select + + end if + end if + if (allocated(prec%rprcparm)) val = val + psb_sizeof_dp * size(prec%rprcparm) +!!$ if (allocated(prec%d)) val = val + psb_sizeof_dp * size(prec%d) +!!$ if (allocated(prec%perm)) val = val + psb_sizeof_int * size(prec%perm) +!!$ if (allocated(prec%invperm)) val = val + psb_sizeof_int * size(prec%invperm) +!!$ val = val + psb_sizeof(prec%desc_data) +!!$ if (allocated(prec%av)) then +!!$ do i=1,size(prec%av) +!!$ val = val + psb_sizeof(prec%av(i)) +!!$ end do +!!$ end if + + + end function mld_sbaseprec_sizeof + + function mld_s_onelev_prec_sizeof(prec) result(val) + implicit none + type(mld_sonelev_type), intent(in) :: prec + integer(psb_long_int_k_) :: val + integer :: i + + val = mld_sizeof(prec%prec) + if (allocated(prec%iprcparm)) & + & val = val + psb_sizeof_int * size(prec%iprcparm) +!!$ if (allocated(prec%ilaggr)) & +!!$ & val = val + psb_sizeof_int * size(prec%ilaggr) +!!$ if (allocated(prec%nlaggr)) & +!!$ & val = val + psb_sizeof_int * size(prec%nlaggr) + if (allocated(prec%rprcparm)) val = val + psb_sizeof_dp * size(prec%rprcparm) + val = val + psb_sizeof(prec%desc_ac) + val = val + psb_sizeof(prec%ac) + val = val + psb_sizeof(prec%map) + if (allocated(prec%sm)) val = val + prec%sm%sizeof() + end function mld_s_onelev_prec_sizeof + + ! + ! Subroutine: mld_file_prec_descr + ! Version: real + ! + ! This routine prints a description of the preconditioner to the standard + ! output or to a file. It must be called after the preconditioner has been + ! built by mld_precbld. + ! + ! Arguments: + ! p - type(mld_Tprec_type), input. + ! The preconditioner data structure to be printed out. + ! info - integer, output. + ! error code. + ! iout - integer, input, optional. + ! The id of the file where the preconditioner description + ! will be printed. If iout is not present, then the standard + ! output is condidered. + ! + subroutine mld_sfile_prec_descr(p,info,iout) + implicit none + ! Arguments + type(mld_sprec_type), intent(in) :: p + integer, intent(out) :: info + integer, intent(in), optional :: iout + + ! Local variables + integer :: ilev, nlev + integer :: ictxt, me, np + character(len=20), parameter :: name='mld_file_prec_descr' + integer :: iout_ + + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + end if + if (iout_ < 0) iout_ = 6 + + ictxt = p%ictxt + + if (allocated(p%precv)) then +!!$ ictxt = psb_cd_get_context(p%precv(1)%prec%desc_data) + + call psb_info(ictxt,me,np) + + ! + ! The preconditioner description is printed by processor psb_root_. + ! This agrees with the fact that all the parameters defining the + ! preconditioner have the same values on all the procs (this is + ! ensured by mld_precbld). + ! + if (me == psb_root_) then + + write(iout_,*) + write(iout_,'(a)') 'Preconditioner description' + nlev = size(p%precv) + if (nlev >= 1) then + ! + ! Print description of base preconditioner + ! + if (nlev > 1) then + write(iout_,*) 'Multilevel Schwarz' + write(iout_,*) + write(iout_,*) 'Base preconditioner (smoother) details' + endif + call p%precv(1)%sm%descr(info,iout=iout_) +!!$ +!!$ +!!$ ilev = 1 +!!$ call mld_base_prec_descr(iout_,p%precv(ilev)%prec%iprcparm,info,& +!!$ & dprcparm=p%precv(ilev)%prec%rprcparm) +!!$ + end if + + if (nlev > 1) then + + ! + ! Print multilevel details + ! + write(iout_,*) + write(iout_,*) 'Multilevel details' + + do ilev = 2, nlev + if (.not.allocated(p%precv(ilev)%iprcparm)) then + info = 3111 + write(iout_,*) ' ',name,& + & ': error: inconsistent MLPREC part, should call MLD_PRECINIT' + return + endif + end do + + write(iout_,*) ' Number of levels: ',nlev + + ! + ! Currently, all the preconditioner parameters must have + ! the same value at levels + ! 2,...,nlev-1, hence only the values at level 2 are printed + ! + + ilev=2 + call mld_ml_alg_descr(iout_,ilev,p%precv(ilev)%iprcparm, info,& + & rprcparm=p%precv(ilev)%rprcparm) +!!$ +!!$ ! +!!$ ! Coarse matrices are different at levels 2,...,nlev-1, hence related +!!$ ! info is printed separately +!!$ ! + write(iout_,*) + do ilev = 2, nlev-1 + call mld_ml_level_descr(iout_,ilev,p%precv(ilev)%iprcparm,& + & p%precv(ilev)%map%naggr,info,& + & rprcparm=p%precv(ilev)%rprcparm) + call p%precv(ilev)%sm%descr(info,iout=iout_) + + end do +!!$ +!!$ ! +!!$ ! Print coarsest level details +!!$ ! +!!$ + ilev = nlev + write(iout_,*) + call mld_ml_new_coarse_descr(iout_,ilev,& + & p%precv(ilev)%iprcparm,& + & p%precv(ilev)%map%naggr,info,& + & rprcparm=p%precv(ilev)%rprcparm) + call p%precv(ilev)%sm%descr(info,iout=iout_) + end if + + endif + write(iout_,*) + else + write(iout_,*) trim(name), & + & ': Error: no base preconditioner available, something is wrong!' + info = -2 + return + endif + + + end subroutine mld_sfile_prec_descr + + ! + ! Subroutines: mld_Tbase_precfree, mld_T_onelev_precfree, mld_Tprec_free + ! Version: real/complex + ! + ! These routines deallocate the mld_Tbaseprec_type, mld_Tonelev_type and + ! mld_Tprec_type data structures. + ! + ! Arguments: + ! p - type(mld_Tbaseprec_type/mld_Tonelev_type/mld_Tprec_type), input. + ! The data structure to be deallocated. + ! info - integer, output. + ! error code. + ! + subroutine mld_sbase_precfree(p,info) + implicit none + + type(mld_sbaseprec_type), intent(inout) :: p + integer, intent(out) :: info + integer :: i + + info = psb_success_ + + ! Actually we might just deallocate the top level array, except + ! for the inner UMFPACK or SLU stuff + +!!$ if (allocated(p%d)) then +!!$ deallocate(p%d,stat=info) +!!$ end if +!!$ +!!$ if (allocated(p%av)) then +!!$ do i=1,size(p%av) +!!$ call p%av(i)%free() +!!$ if (info /= psb_success_) then +!!$ ! Actually, we don't care here about this. +!!$ ! Just let it go. +!!$ ! return +!!$ end if +!!$ enddo +!!$ deallocate(p%av,stat=info) +!!$ end if +!!$ +!!$ if (allocated(p%desc_data%matrix_data)) & +!!$ & call psb_cdfree(p%desc_data,info) +!!$ + if (allocated(p%rprcparm)) then + deallocate(p%rprcparm,stat=info) + end if + +!!$ if (allocated(p%perm)) then +!!$ deallocate(p%perm,stat=info) +!!$ endif +!!$ +!!$ if (allocated(p%invperm)) then +!!$ deallocate(p%invperm,stat=info) +!!$ endif + + if (allocated(p%iprcparm)) then + if (p%iprcparm(mld_prec_status_) == mld_prec_built_) then + if (p%iprcparm(mld_sub_solve_) == mld_slu_) then + call mld_sslu_free(p%iprcparm(mld_slu_ptr_),info) + end if + end if + deallocate(p%iprcparm,stat=info) + end if + call mld_nullify_baseprec(p) + + end subroutine mld_sbase_precfree + + subroutine mld_s_onelev_precfree(p,info) + implicit none + + type(mld_sonelev_type), intent(inout) :: p + integer, intent(out) :: info + integer :: i + + info = psb_success_ + + ! Actually we might just deallocate the top level array, except + ! for the inner UMFPACK or SLU stuff + call mld_precfree(p%prec,info) + + call p%ac%free() + if (allocated(p%desc_ac%matrix_data)) & + & call psb_cdfree(p%desc_ac,info) + + if (allocated(p%rprcparm)) then + deallocate(p%rprcparm,stat=info) + end if + ! This is a pointer to something else, must not free it here. + nullify(p%base_a) + ! This is a pointer to something else, must not free it here. + nullify(p%base_desc) + + ! + ! free explicitly map??? + ! For now thanks to allocatable semantics + ! works anyway. + ! + + call mld_nullify_onelevprec(p) + end subroutine mld_s_onelev_precfree + + subroutine mld_nullify_dbaseprec(p) + implicit none + + type(mld_sbaseprec_type), intent(inout) :: p + + + end subroutine mld_nullify_dbaseprec + + subroutine mld_nullify_d_onelevprec(p) + implicit none + + type(mld_sonelev_type), intent(inout) :: p + + nullify(p%base_a) + nullify(p%base_desc) + + end subroutine mld_nullify_d_onelevprec + + subroutine mld_sprec_free(p,info) + + use psb_sparse_mod + + implicit none + + ! Arguments + type(mld_sprec_type), intent(inout) :: p + integer, intent(out) :: info + + ! Local variables + integer :: me,err_act,i + character(len=20) :: name + + if(psb_get_errstatus().ne.0) return + info=psb_success_ + name = 'mld_sprecfree' + call psb_erractionsave(err_act) + + me=-1 + + if (allocated(p%precv)) then + do i=1,size(p%precv) + call mld_precfree(p%precv(i),info) + end do + deallocate(p%precv) + end if + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine mld_sprec_free + + + subroutine s_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) + use psb_sparse_mod + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_base_smoother_type), intent(in) :: sm + real(psb_spk_),intent(in) :: 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 :: err_act + character(len=20) :: name='d_base_smoother_apply' + + call psb_erractionsave(err_act) + info = psb_success_ + if (allocated(sm%sv)) then + call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info) + else + info = 1121 + endif + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine s_base_smoother_apply + + subroutine s_base_smoother_seti(sm,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_base_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_base_smoother_seti' + + call psb_erractionsave(err_act) + info = psb_success_ + + if (allocated(sm%sv)) then + call sm%sv%set(what,val,info) + 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_base_smoother_seti + + subroutine s_base_smoother_setc(sm,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_base_smoother_type), intent(inout) :: sm + integer, intent(in) :: what + character(len=*), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_base_smoother_setc' + + call psb_erractionsave(err_act) + + info = psb_success_ + + if (allocated(sm%sv)) then + call sm%sv%set(what,val,info) + 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_base_smoother_setc + + subroutine s_base_smoother_setr(sm,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_base_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='d_base_smoother_setr' + + call psb_erractionsave(err_act) + + + info = psb_success_ + + if (allocated(sm%sv)) then + call sm%sv%set(what,val,info) + 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_base_smoother_setr + + subroutine s_base_smoother_bld(a,desc_a,sm,upd,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_s_base_smoother_type), intent(inout) :: sm + character, intent(in) :: upd + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_base_smoother_bld' + + call psb_erractionsave(err_act) + + info = psb_success_ + if (allocated(sm%sv)) then + call sm%sv%build(a,desc_a,upd,info) + else + info = 1121 + call psb_errpush(info,name) + endif + 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_base_smoother_bld + + + subroutine s_base_smoother_free(sm,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_base_smoother_type), intent(inout) :: sm + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_base_smoother_free' + + call psb_erractionsave(err_act) + info = psb_success_ + + if (allocated(sm%sv)) then + call sm%sv%free(info) + end if + 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 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_base_smoother_free + + subroutine s_base_smoother_descr(sm,info,iout) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_base_smoother_type), intent(in) :: sm + integer, intent(out) :: info + integer, intent(in), optional :: iout + + ! Local variables + integer :: err_act + integer :: ictxt, me, np + character(len=20), parameter :: name='mld_s_base_smoother_descr' + integer :: iout_ + + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + end if + + write(iout_,*) 'Base smoother with local solver' + if (allocated(sm%sv)) then + call sm%sv%descr(info,iout) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Local solver') + goto 9999 + end if + 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_base_smoother_descr + + function s_base_smoother_sizeof(sm) result(val) + implicit none + ! Arguments + class(mld_s_base_smoother_type), intent(in) :: sm + integer(psb_long_int_k_) :: val + integer :: i + + val = 0 + if (allocated(sm%sv)) then + val = sm%sv%sizeof() + end if + + return + end function s_base_smoother_sizeof + + subroutine s_base_smoother_default(sm) + implicit none + ! Arguments + class(mld_s_base_smoother_type), intent(inout) :: sm + ! Do nothing for base version + + return + end subroutine s_base_smoother_default + + + + subroutine s_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + use psb_sparse_mod + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_base_solver_type), intent(in) :: sv + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_spk_),target, intent(inout) :: work(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='d_base_solver_apply' + + call psb_erractionsave(err_act) + + info = 700 + call psb_errpush(info,name) + 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_base_solver_apply + + subroutine s_base_solver_bld(a,desc_a,sv,upd,info,b) + + use psb_sparse_mod + + Implicit None + + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_s_base_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer, intent(out) :: info + type(psb_sspmat_type), intent(in), target, optional :: b + Integer :: err_act + character(len=20) :: name='d_base_solver_bld' + + call psb_erractionsave(err_act) + + info = 700 + call psb_errpush(info,name) + 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_base_solver_bld + + + subroutine s_base_solver_seti(sv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_base_solver_type), intent(inout) :: sv + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_base_solver_seti' + + call psb_erractionsave(err_act) + + info = 700 + call psb_errpush(info,name) + 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_base_solver_seti + + subroutine s_base_solver_setc(sv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_base_solver_type), intent(inout) :: sv + integer, intent(in) :: what + character(len=*), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_base_solver_setc' + + call psb_erractionsave(err_act) + + info = 700 + call psb_errpush(info,name) + 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_base_solver_setc + + subroutine s_base_solver_setr(sv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_base_solver_type), intent(inout) :: sv + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_base_solver_setr' + + call psb_erractionsave(err_act) + + info = 700 + call psb_errpush(info,name) + 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_base_solver_setr + + subroutine s_base_solver_free(sv,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_base_solver_type), intent(inout) :: sv + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_base_solver_free' + + call psb_erractionsave(err_act) + + info = 700 + call psb_errpush(info,name) + 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_base_solver_free + + subroutine s_base_solver_descr(sv,info,iout) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_s_base_solver_type), intent(in) :: sv + integer, intent(out) :: info + integer, intent(in), optional :: iout + + ! Local variables + integer :: err_act + integer :: ictxt, me, np + character(len=20), parameter :: name='mld_s_base_solver_descr' + integer :: iout_ + + + call psb_erractionsave(err_act) + + info = 700 + call psb_errpush(info,name) + 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_base_solver_descr + + function s_base_solver_sizeof(sv) result(val) + implicit none + ! Arguments + class(mld_s_base_solver_type), intent(in) :: sv + integer(psb_long_int_k_) :: val + integer :: i + val = 0 + + return + end function s_base_solver_sizeof + + subroutine s_base_solver_default(sv) + implicit none + ! Arguments + class(mld_s_base_solver_type), intent(inout) :: sv + ! Do nothing for base version + + return + end subroutine s_base_solver_default + + + subroutine mld_s_apply2v(prec,x,y,desc_data,info,trans,work) + use psb_sparse_mod + type(psb_desc_type),intent(in) :: desc_data + class(mld_sprec_type), intent(in) :: prec + real(psb_spk_),intent(in) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + integer, intent(out) :: info + character(len=1), optional :: trans + real(psb_spk_),intent(inout), optional, target :: work(:) + Integer :: err_act + character(len=20) :: name='d_prec_apply' + + call psb_erractionsave(err_act) + + select type(prec) + type is (mld_sprec_type) + call mld_precaply(prec,x,y,desc_data,info,trans,work) + class default + info = 700 + call psb_errpush(info,name) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine mld_s_apply2v + + subroutine mld_s_apply1v(prec,x,desc_data,info,trans) + use psb_sparse_mod + type(psb_desc_type),intent(in) :: desc_data + class(mld_sprec_type), intent(in) :: prec + real(psb_spk_),intent(inout) :: x(:) + integer, intent(out) :: info + character(len=1), optional :: trans + Integer :: err_act + character(len=20) :: name='d_prec_apply' + + call psb_erractionsave(err_act) + + select type(prec) + type is (mld_sprec_type) + call mld_precaply(prec,x,desc_data,info,trans) + class default + info = 700 + call psb_errpush(info,name) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine mld_s_apply1v + + subroutine s_base_onelev_seti(lv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_sonelev_type), intent(inout) :: lv + integer, intent(in) :: what + integer, intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_base_onelev_seti' + + call psb_erractionsave(err_act) + info = psb_success_ + + select case (what) + case (mld_smoother_sweeps_) + lv%sweeps = val + lv%sweeps_pre = val + lv%sweeps_post = val + case (mld_smoother_sweeps_pre_) + lv%sweeps_pre = val + case (mld_smoother_sweeps_post_) + lv%sweeps_post = val + case default + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + if (info /= psb_success_) goto 9999 + end select + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + end subroutine s_base_onelev_seti + + subroutine s_base_onelev_setc(lv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_sonelev_type), intent(inout) :: lv + integer, intent(in) :: what + character(len=*), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_base_onelev_setc' + + call psb_erractionsave(err_act) + + info = psb_success_ + + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + 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_base_onelev_setc + + subroutine s_base_onelev_setr(lv,what,val,info) + + use psb_sparse_mod + + Implicit None + + ! Arguments + class(mld_sonelev_type), intent(inout) :: lv + integer, intent(in) :: what + real(psb_spk_), intent(in) :: val + integer, intent(out) :: info + Integer :: err_act + character(len=20) :: name='d_base_onelev_setr' + + call psb_erractionsave(err_act) + + + info = psb_success_ + + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + 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_base_onelev_setr + + +end module mld_s_prec_type diff --git a/mlprec/mld_s_prec_type.f90 b/mlprec/mld_s_prec_type.f90 deleted file mode 100644 index 4699ddf4..00000000 --- a/mlprec/mld_s_prec_type.f90 +++ /dev/null @@ -1,702 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,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. -!!$ -!!$ -! File: mld_prec_type.f90 -! -! Module: mld_prec_type -! -! This module defines: -! - the mld_prec_type data structure containing the preconditioner and related -! data structures; -! - integer constants defining the preconditioner; -! - character constants describing the preconditioner (used by the routines -! printing out a preconditioner description); -! - the interfaces to the routines for the management of the preconditioner -! data structure (see below). -! -! It contains routines for -! - converting character constants defining the preconditioner into integer -! constants; -! - checking if the preconditioner is correctly defined; -! - printing a description of the preconditioner; -! - deallocating the preconditioner data structure. -! - -module mld_s_prec_type - - use mld_base_prec_type - - ! - ! Type: mld_Tprec_type. - ! - ! It is the data type containing all the information about the multilevel - ! preconditioner (here and in the following 'T' denotes 'd', 's', 'c' and - ! 'z', according to the real/complex, single/double precision version of - ! MLD2P4). It consists of an array of 'one-level' intermediate data structures - ! of type mld_Tonelev_type, each containing the information needed to apply - ! the smoothing and the coarse-space correction at a generic level. - ! - ! type mld_Tprec_type - ! type(mld_Tonelev_type), allocatable :: precv(:) - ! end type mld_Tprec_type - ! - ! Note that the levels are numbered in increasing order starting from - ! the finest one and the number of levels is given by size(precv(:)). - ! - ! - ! Type: mld_Tonelev_type. - ! - ! It is the data type containing the necessary items for the current - ! level (essentially, the base preconditioner, the current-level matrix - ! and the restriction and prolongation operators). - ! - ! type mld_Tonelev_type - ! type(mld_Tbaseprec_type) :: prec - ! integer, allocatable :: iprcparm(:) - ! real(psb_Tpk_), allocatable :: rprcparm(:) - ! type(psb_Tspmat_type) :: ac - ! type(psb_desc_type) :: desc_ac - ! type(psb_Tspmat_type), pointer :: base_a => null() - ! type(psb_desc_type), pointer :: base_desc => null() - ! type(psb_Tlinmap_type) :: map - ! end type mld_Tonelev_type - ! - ! Note that psb_Tpk denotes the kind of the real data type to be chosen - ! according to single/double precision version of MLD2P4. - ! - ! prec - type(mld_Tbaseprec_type). - ! The current level preconditioner (aka smoother). - ! iprcparm - integer, dimension(:), allocatable. - ! The integer parameters defining the multilevel strategy. - ! rprcparm - real(psb_Ypk_), dimension(:), allocatable. - ! The real parameters defining the multilevel strategy. - ! ac - The local part of the current-level matrix, built by - ! coarsening the previous-level matrix. - ! desc_ac - type(psb_desc_type). - ! The communication descriptor associated to the matrix - ! stored in ac. - ! base_a - type(psb_zspmat_type), pointer. - ! Pointer (really a pointer!) to the local part of the current - ! matrix (so we have a unified treatment of residuals). - ! We need this to avoid passing explicitly the current matrix - ! to the routine which applies the preconditioner. - ! base_desc - type(psb_desc_type), pointer. - ! Pointer to the communication descriptor associated to the - ! matrix pointed by base_a. - ! map - Stores the maps (restriction and prolongation) between the - ! vector spaces associated to the index spaces of the previous - ! and current levels. - ! - ! - ! Type: mld_Tbaseprec_type. - ! - ! It holds the smoother (base preconditioner) at a single level. - ! - ! type mld_Tbaseprec_type - ! type(psb_Tspmat_type), allocatable :: av(:) - ! IntrType(psb_Tpk_), allocatable :: d(:) - ! type(psb_desc_type) :: desc_data - ! integer, allocatable :: iprcparm(:) - ! real(psb_Tpk_), allocatable :: rprcparm(:) - ! integer, allocatable :: perm(:), invperm(:) - ! end type mld_sbaseprec_type - ! - ! Note that IntrType denotes the real or complex data type, and psb_Tpk denotes - ! the kind of the real or complex type, according to the real/complex, single/double - ! precision version of MLD2P4. - ! - ! av - type(psb_Tspmat_type), dimension(:), allocatable(:). - ! The sparse matrices needed to apply the preconditioner at - ! the current level ilev. - ! av(mld_l_pr_) - The L factor of the ILU factorization of the local - ! diagonal block of the current-level matrix A(ilev). - ! av(mld_u_pr_) - The U factor of the ILU factorization of the local - ! diagonal block of A(ilev), except its diagonal entries - ! (stored in d). - ! av(mld_ap_nd_) - The entries of the local part of A(ilev) outside - ! the diagonal block, for block-Jacobi sweeps. - ! d - real/complex(psb_Tpk_), dimension(:), allocatable. - ! The diagonal entries of the U factor in the ILU factorization - ! of A(ilev). - ! desc_data - type(psb_desc_type). - ! The communication descriptor associated to the base preconditioner, - ! i.e. to the sparse matrices needed to apply the base preconditioner - ! at the current level. - ! iprcparm - integer, dimension(:), allocatable. - ! The integer parameters defining the base preconditioner K(ilev) - ! (the iprcparm entries and values are specified below). - ! rprcparm - real(psb_Tpk_), dimension(:), allocatable. - ! The real parameters defining the base preconditioner K(ilev) - ! (the rprcparm entries and values are specified below). - ! perm - integer, dimension(:), allocatable. - ! The row and column permutations applied to the local part of - ! A(ilev) (defined only if iprcparm(mld_sub_ren_)>0). - ! invperm - integer, dimension(:), allocatable. - ! The inverse of the permutation stored in perm. - ! - ! Note that when the LU factorization of the (local part of the) matrix A(ilev) is - ! computed instead of the ILU one, by using UMFPACK, SuperLU or SuperLU_dist, the - ! corresponding L and U factors are stored in data structures provided by those - ! packages and pointed by prec%iprcparm(mld_umf_ptr), prec%iprcparm(mld_slu_ptr) - ! or prec%iprcparm(mld_slud_ptr). - ! - - type mld_sbaseprec_type - type(psb_sspmat_type), allocatable :: av(:) - real(psb_spk_), allocatable :: d(:) - type(psb_desc_type) :: desc_data - integer, allocatable :: iprcparm(:) - real(psb_spk_), allocatable :: rprcparm(:) - integer, allocatable :: perm(:), invperm(:) - end type mld_sbaseprec_type - - type mld_sonelev_type - type(mld_sbaseprec_type) :: prec - integer, allocatable :: iprcparm(:) - real(psb_spk_), allocatable :: rprcparm(:) - type(psb_sspmat_type) :: ac - type(psb_desc_type) :: desc_ac - type(psb_sspmat_type), pointer :: base_a => null() - type(psb_desc_type), pointer :: base_desc => null() - type(psb_slinmap_type) :: map - end type mld_sonelev_type - - - type, extends(psb_sprec_type) :: mld_sprec_type - type(mld_sonelev_type), allocatable :: precv(:) - contains - procedure, pass(prec) :: s_apply2v => mld_s_apply2v - procedure, pass(prec) :: s_apply1v => mld_s_apply1v - end type mld_sprec_type - - - ! - ! Interfaces to routines for checking the definition of the preconditioner, - ! for printing its description and for deallocating its data structure - ! - - interface mld_precfree - module procedure mld_sbase_precfree, mld_s_onelev_precfree, mld_sprec_free - end interface - - interface mld_nullify_baseprec - module procedure mld_nullify_sbaseprec - end interface - - interface mld_nullify_onelevprec - module procedure mld_nullify_s_onelevprec - end interface - - - interface mld_precdescr - module procedure mld_sfile_prec_descr - end interface - - - interface mld_sizeof - module procedure mld_sprec_sizeof, mld_sbaseprec_sizeof, mld_s_onelev_prec_sizeof - end interface - - - interface mld_precaply - subroutine mld_sprecaply(prec,x,y,desc_data,info,trans,work) - use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ - import mld_sprec_type - type(psb_desc_type),intent(in) :: desc_data - type(mld_sprec_type), intent(in) :: prec - real(psb_spk_),intent(in) :: x(:) - real(psb_spk_),intent(inout) :: y(:) - integer, intent(out) :: info - character(len=1), optional :: trans - real(psb_spk_),intent(inout), optional, target :: work(:) - end subroutine mld_sprecaply - subroutine mld_sprecaply1(prec,x,desc_data,info,trans) - use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ - import mld_sprec_type - type(psb_desc_type),intent(in) :: desc_data - type(mld_sprec_type), intent(in) :: prec - real(psb_spk_),intent(inout) :: x(:) - integer, intent(out) :: info - character(len=1), optional :: trans - end subroutine mld_sprecaply1 - end interface - -contains - ! - ! Function returning the size of the mld_prec_type data structure - ! - - function mld_sprec_sizeof(prec) result(val) - implicit none - type(mld_sprec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val - integer :: i - val = 0 - if (allocated(prec%precv)) then - do i=1, size(prec%precv) - val = val + mld_sizeof(prec%precv(i)) - end do - end if - end function mld_sprec_sizeof - - function mld_sbaseprec_sizeof(prec) result(val) - implicit none - type(mld_sbaseprec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val - integer :: i - - val = 0 - if (allocated(prec%iprcparm)) then - val = val + psb_sizeof_int * size(prec%iprcparm) - if (prec%iprcparm(mld_prec_status_) == mld_prec_built_) then - select case(prec%iprcparm(mld_sub_solve_)) - case(mld_ilu_n_,mld_ilu_t_) - ! do nothing - case(mld_slu_) - case(mld_umf_) - case(mld_sludist_) - case default - end select - - end if - end if - if (allocated(prec%rprcparm)) val = val + psb_sizeof_sp * size(prec%rprcparm) - if (allocated(prec%d)) val = val + psb_sizeof_sp * size(prec%d) - if (allocated(prec%perm)) val = val + psb_sizeof_int * size(prec%perm) - if (allocated(prec%invperm)) val = val + psb_sizeof_int * size(prec%invperm) - val = val + psb_sizeof(prec%desc_data) - if (allocated(prec%av)) then - do i=1,size(prec%av) - val = val + psb_sizeof(prec%av(i)) - end do - end if - - end function mld_sbaseprec_sizeof - - function mld_s_onelev_prec_sizeof(prec) result(val) - implicit none - type(mld_sonelev_type), intent(in) :: prec - integer(psb_long_int_k_) :: val - integer :: i - - val = mld_sizeof(prec%prec) - if (allocated(prec%iprcparm)) then - val = val + psb_sizeof_int * size(prec%iprcparm) - end if - if (allocated(prec%rprcparm)) val = val + psb_sizeof_sp * size(prec%rprcparm) - val = val + psb_sizeof(prec%desc_ac) - val = val + psb_sizeof(prec%ac) - val = val + psb_sizeof(prec%map) - - end function mld_s_onelev_prec_sizeof - - ! - ! Subroutine: mld_file_prec_descr - ! Version: real - ! - ! This routine prints a description of the preconditioner to the standard - ! output or to a file. It must be called after the preconditioner has been - ! built by mld_precbld. - ! - ! Arguments: - ! p - type(mld_Tprec_type), input. - ! The preconditioner data structure to be printed out. - ! info - integer, output. - ! error code. - ! iout - integer, input, optional. - ! The id of the file where the preconditioner description - ! will be printed. If iout is not present, then the standard - ! output is condidered. - ! - subroutine mld_sfile_prec_descr(p,info,iout) - implicit none - - ! Arguments - type(mld_sprec_type), intent(in) :: p - integer, intent(out) :: info - integer, intent(in), optional :: iout - - ! Local variables - integer :: ilev, nlev - integer :: ictxt, me, np - character(len=20), parameter :: name='mld_file_prec_descr' - integer :: iout_ - - info = psb_success_ - if (present(iout)) then - iout_ = iout - else - iout_ = 6 - end if - if (iout_ < 0) iout_ = 6 - - if (allocated(p%precv)) then - ictxt = psb_cd_get_context(p%precv(1)%prec%desc_data) - - call psb_info(ictxt,me,np) - - ! - ! The preconditioner description is printed by processor psb_root_. - ! This agrees with the fact that all the parameters defining the - ! preconditioner have the same values on all the procs (this is - ! ensured by mld_precbld). - ! - if (me == psb_root_) then - - write(iout_,*) - write(iout_,*) 'Preconditioner description' - nlev = size(p%precv) - if (nlev >= 1) then - ! - ! Print description of base preconditioner - ! - - write(iout_,*) ' ' - - if (nlev > 1) then - write(iout_,*) 'Multilevel Schwarz' - write(iout_,*) - write(iout_,*) 'Base preconditioner (smoother) details' - endif - - ilev = 1 - call mld_base_prec_descr(iout_,p%precv(ilev)%prec%iprcparm,info,& - & rprcparm=p%precv(ilev)%prec%rprcparm) - - end if - - if (nlev > 1) then - - ! - ! Print multilevel details - ! - write(iout_,*) - write(iout_,*) 'Multilevel details' - - do ilev = 2, nlev - if (.not.allocated(p%precv(ilev)%iprcparm)) then - info = 3111 - write(iout_,*) ' ',name,': error: inconsistent MLPREC part, should call MLD_PRECINIT' - return - endif - end do - - write(iout_,*) ' Number of levels: ',nlev - - ! - ! Currently, all the preconditioner parameters must have the same value at levels - ! 2,...,nlev-1, hence only the values at level 2 are printed - ! - - ilev=2 - call mld_ml_alg_descr(iout_,ilev,p%precv(ilev)%iprcparm, info,& - & rprcparm=p%precv(ilev)%rprcparm) - - ! - ! Coarse matrices are different at levels 2,...,nlev-1, hence related - ! info is printed separately - ! - write(iout_,*) - do ilev = 2, nlev-1 - call mld_ml_level_descr(iout_,ilev,p%precv(ilev)%iprcparm,& - & p%precv(ilev)%map%naggr,info,& - & rprcparm=p%precv(ilev)%rprcparm) - end do - - ! - ! Print coarsest level details - ! - - ilev = nlev - write(iout_,*) - call mld_ml_coarse_descr(iout_,ilev,& - & p%precv(ilev)%iprcparm,p%precv(ilev)%prec%iprcparm,& - & p%precv(ilev)%map%naggr,info,& - & rprcparm=p%precv(ilev)%rprcparm, & - & rprcparm2=p%precv(ilev)%prec%rprcparm) - - end if - - endif - write(iout_,*) - else - - write(iout_,*) trim(name), & - & ': Error: no base preconditioner available, something is wrong!' - info = -2 - return - endif - - - end subroutine mld_sfile_prec_descr - - - ! - ! Subroutines: mld_Tbase_precfree, mld_T_onelev_precfree, mld_Tprec_free - ! Version: real/complex - ! - ! These routines deallocate the mld_Tbaseprec_type, mld_Tonelev_type and - ! mld_Tprec_type data structures. - ! - ! Arguments: - ! p - type(mld_Tbaseprec_type/mld_Tonelev_type/mld_Tprec_type), input. - ! The data structure to be deallocated. - ! info - integer, output. - ! error code. - ! - subroutine mld_sbase_precfree(p,info) - implicit none - - type(mld_sbaseprec_type), intent(inout) :: p - integer, intent(out) :: info - integer :: i - - info = psb_success_ - - ! Actually we might just deallocate the top level array, except - ! for the inner UMFPACK or SLU stuff - - if (allocated(p%d)) then - deallocate(p%d,stat=info) - end if - - if (allocated(p%av)) then - do i=1,size(p%av) - call p%av(i)%free() - if (info /= psb_success_) then - ! Actually, we don't care here about this. - ! Just let it go. - ! return - end if - enddo - deallocate(p%av,stat=info) - end if - - if (allocated(p%desc_data%matrix_data)) & - & call psb_cdfree(p%desc_data,info) - - if (allocated(p%rprcparm)) then - deallocate(p%rprcparm,stat=info) - end if - - - if (allocated(p%perm)) then - deallocate(p%perm,stat=info) - endif - - if (allocated(p%invperm)) then - deallocate(p%invperm,stat=info) - endif - - if (allocated(p%iprcparm)) then - if (p%iprcparm(mld_prec_status_) == mld_prec_built_) then - if (p%iprcparm(mld_sub_solve_) == mld_slu_) then - call mld_sslu_free(p%iprcparm(mld_slu_ptr_),info) - end if - end if - deallocate(p%iprcparm,stat=info) - end if - call mld_nullify_baseprec(p) - end subroutine mld_sbase_precfree - - - subroutine mld_s_onelev_precfree(p,info) - implicit none - - type(mld_sonelev_type), intent(inout) :: p - integer, intent(out) :: info - integer :: i - - info = psb_success_ - - ! Actually we might just deallocate the top level array, except - ! for the inner UMFPACK or SLU stuff - call mld_precfree(p%prec,info) - - call p%ac%free() - if (allocated(p%desc_ac%matrix_data)) & - & call psb_cdfree(p%desc_ac,info) - - if (allocated(p%rprcparm)) then - deallocate(p%rprcparm,stat=info) - end if - ! This is a pointer to something else, must not free it here. - nullify(p%base_a) - ! This is a pointer to something else, must not free it here. - nullify(p%base_desc) - - ! - ! free explicitly map??? - ! For now thanks to allocatable semantics - ! works anyway. - ! - - call mld_nullify_onelevprec(p) - end subroutine mld_s_onelev_precfree - - - subroutine mld_nullify_s_onelevprec(p) - implicit none - - type(mld_sonelev_type), intent(inout) :: p - - nullify(p%base_a) - nullify(p%base_desc) - - end subroutine mld_nullify_s_onelevprec - - subroutine mld_nullify_sbaseprec(p) - implicit none - - type(mld_sbaseprec_type), intent(inout) :: p - - - end subroutine mld_nullify_sbaseprec - - - subroutine mld_sprec_free(p,info) - - use psb_sparse_mod - - implicit none - - ! Arguments - type(mld_sprec_type), intent(inout) :: p - integer, intent(out) :: info - - ! Local variables - integer :: me,err_act,i - character(len=20) :: name - - if(psb_get_errstatus().ne.0) return - info=psb_success_ - name = 'mld_dprecfree' - call psb_erractionsave(err_act) - - me=-1 - - if (allocated(p%precv)) then - do i=1,size(p%precv) - call mld_precfree(p%precv(i),info) - end do - deallocate(p%precv) - end if - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine mld_sprec_free - - - - subroutine mld_s_apply2v(prec,x,y,desc_data,info,trans,work) - use psb_sparse_mod - type(psb_desc_type),intent(in) :: desc_data - class(mld_sprec_type), intent(in) :: prec - real(psb_spk_),intent(in) :: x(:) - real(psb_spk_),intent(inout) :: y(:) - integer, intent(out) :: info - character(len=1), optional :: trans - real(psb_spk_),intent(inout), optional, target :: work(:) - Integer :: err_act - character(len=20) :: name='s_prec_apply' - - call psb_erractionsave(err_act) - - select type(prec) - type is (mld_sprec_type) -!!$ call mld_precaply(prec,x,y,desc_data,info,trans,work) - class default - info = 700 - call psb_errpush(info,name) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine mld_s_apply2v - subroutine mld_s_apply1v(prec,x,desc_data,info,trans) - use psb_sparse_mod - type(psb_desc_type),intent(in) :: desc_data - class(mld_sprec_type), intent(in) :: prec - real(psb_spk_),intent(inout) :: x(:) - integer, intent(out) :: info - character(len=1), optional :: trans - Integer :: err_act - character(len=20) :: name='s_prec_apply' - - call psb_erractionsave(err_act) - - select type(prec) - type is (mld_sprec_type) -!!$ call mld_precaply(prec,x,desc_data,info,trans) - class default - info = 700 - call psb_errpush(info,name) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - end subroutine mld_s_apply1v - -end module mld_s_prec_type diff --git a/mlprec/mld_saggrmap_bld.f90 b/mlprec/mld_saggrmap_bld.f90 index daf81d29..72afe3df 100644 --- a/mlprec/mld_saggrmap_bld.f90 +++ b/mlprec/mld_saggrmap_bld.f90 @@ -121,19 +121,20 @@ subroutine mld_saggrmap_bld(aggr_type,theta,a,desc_a,ilaggr,nlaggr,info) call mld_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info) case (mld_sym_dec_aggr_) - nr = psb_sp_get_nrows(a) - call psb_sp_clip(a,atmp,info,imax=nr,jmax=nr,& + nr = a%get_nrows() + call a%csclip(atmp,info,imax=nr,jmax=nr,& & rscale=.false.,cscale=.false.) - atmp%m=nr - atmp%k=nr - if (info == psb_success_) call psb_transp(atmp,atrans,fmt='COO') + call atmp%set_nrows(nr) + call atmp%set_ncols(nr) + if (info == psb_success_) call atrans%transp(atmp) + if (info == psb_success_) call atrans%cscnv(info,type='COO') if (info == psb_success_) call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.) - atmp%m=nr - atmp%k=nr - if (info == psb_success_) call psb_sp_free(atrans,info) - if (info == psb_success_) call psb_spcnv(atmp,info,afmt='csr') + call atmp%set_nrows(nr) + call atmp%set_ncols(nr) + if (info == psb_success_) call atrans%free() + if (info == psb_success_) call atmp%cscnv(info,type='CSR') if (info == psb_success_) call mld_dec_map_bld(theta,atmp,desc_a,nlaggr,ilaggr,info) - if (info == psb_success_) call psb_sp_free(atmp,info) + if (info == psb_success_) call atmp%free() case default @@ -198,7 +199,7 @@ contains nrow = psb_cd_get_local_rows(desc_a) ncol = psb_cd_get_local_cols(desc_a) - nr = a%m + nr = a%get_nrows() allocate(ilaggr(nr),neigh(nr),stat=info) if(info /= psb_success_) then info=psb_err_alloc_request_ @@ -214,7 +215,7 @@ contains & a_err='real(psb_spk_)') goto 9999 end if - call psb_sp_getdiag(a,diag,info) + call a%get_diag(diag,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_sp_getdiag') @@ -247,10 +248,10 @@ contains naggr = naggr + 1 ilaggr(i) = naggr - call psb_sp_getrow(i,a,nz,irow,icol,val,info) + call a%csget(i,i,nz,irow,icol,val,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_getrow') + call psb_errpush(info,name,a_err='csget') goto 9999 end if @@ -268,7 +269,7 @@ contains ! ! 2. Untouched neighbours of these nodes are marked <0. ! - call psb_neigh(a,i,neigh,n_ne,info,lev=2) + call a%get_neigh(i,neigh,n_ne,info,lev=2) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_neigh') @@ -288,8 +289,7 @@ contains enddo if (debug_level >= psb_debug_outer_) then write(debug_unit,*) me,' ',trim(name),& - & ' Check 1:',count(ilaggr == -(nr+1)),& - & (a%ia1(i),i=a%ia2(1),a%ia2(2)-1) + & ' Check 1:',count(ilaggr == -(nr+1)) end if ! @@ -336,7 +336,7 @@ contains isz = nr+1 ia = -1 cpling = szero - call psb_sp_getrow(i,a,nz,irow,icol,val,info) + call a%csget(i,i,nz,irow,icol,val,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_sp_getrow') diff --git a/mlprec/mld_saggrmat_nosmth_asb.F90 b/mlprec/mld_saggrmat_nosmth_asb.F90 index 6ba4470d..2d456243 100644 --- a/mlprec/mld_saggrmat_nosmth_asb.F90 +++ b/mlprec/mld_saggrmat_nosmth_asb.F90 @@ -100,12 +100,13 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(mld_sonelev_type), intent(inout), target :: p integer, intent(out) :: info -! Local variables + ! Local variables integer ::ictxt,np,me, err_act, icomm character(len=20) :: name type(psb_sspmat_type) :: b - integer, allocatable :: nzbr(:), idisp(:) - type(psb_sspmat_type) :: am1,am2 + integer, allocatable :: nzbr(:), idisp(:) + type(psb_sspmat_type) :: am1,am2 + type(psb_s_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& & naggr, nzt, naggrm1, i @@ -114,7 +115,6 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) info=psb_success_ call psb_erractionsave(err_act) - call psb_nullify_sp(b) ictxt = psb_cd_get_context(desc_a) icomm = psb_cd_get_mpic(desc_a) @@ -123,9 +123,6 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = psb_cd_get_local_rows(desc_a) ncol = psb_cd_get_local_cols(desc_a) - call psb_nullify_sp(am1) - call psb_nullify_sp(am2) - naggr = nlaggr(me+1) ntaggr = sum(nlaggr) @@ -152,47 +149,36 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then - call psb_sp_all(ncol,ntaggr,am1,ncol,info) + call acoo1%allocate(ncol,ntaggr,ncol) else - call psb_sp_all(ncol,naggr,am1,ncol,info) - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spall') - goto 9999 + call acoo1%allocate(ncol,naggr,ncol) end if do i=1,nrow - am1%aspk(i) = sone - am1%ia1(i) = i - am1%ia2(i) = ilaggr(i) + acoo1%val(i) = done + acoo1%ia(i) = i + acoo1%ja(i) = ilaggr(i) end do - am1%infoa(psb_nnz_) = nrow - call psb_spcnv(am1,info,afmt='csr',dupl=psb_dupl_add_) - call psb_transp(am1,am2) + call acoo1%set_dupl(psb_dupl_add_) + call acoo1%set_nzeros(nrow) + call acoo1%set_asb() + call acoo1%fix(info) + call acoo2%transp(acoo1) + call a%csclip(bcoo,info,jmax=nrow) - call psb_sp_clip(a,b,info,jmax=nrow) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spclip') - goto 9999 - end if - ! Out from sp_clip is always in COO, but just in case.. - if (psb_tolower(b%fida) /= 'coo') then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spclip NOT COO') - goto 9999 - end if - - nzt = psb_sp_get_nnzeros(b) + + nzt = bcoo%get_nzeros() do i=1, nzt - b%ia1(i) = ilaggr(b%ia1(i)) - b%ia2(i) = ilaggr(b%ia2(i)) + bcoo%ia(i) = ilaggr(bcoo%ia(i)) + bcoo%ja(i) = ilaggr(bcoo%ja(i)) enddo - b%m = naggr - b%k = naggr - ! This is to minimize data exchange - call psb_spcnv(b,info,afmt='coo',dupl=psb_dupl_add_) + call bcoo%set_nrows(naggr) + call bcoo%set_ncols(naggr) + call bcoo%set_dupl(psb_dupl_add_) + call bcoo%fix(info) + if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then @@ -206,81 +192,73 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) nzbr(me+1) = nzt call psb_sum(ictxt,nzbr(1:np)) nzac = sum(nzbr) - - call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_all') - goto 9999 - end if + + call ac_coo%allocate(ntaggr,ntaggr,nzac) do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo ndx = nzbr(me+1) - call mpi_allgatherv(b%aspk,ndx,mpi_real,p%ac%aspk,nzbr,idisp,& + call mpi_allgatherv(bcoo%val,ndx,mpi_double_precision,ac_coo%val,nzbr,idisp,& & mpi_real,icomm,info) - call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,& + call mpi_allgatherv(bcoo%ia,ndx,mpi_integer,ac_coo%ia,nzbr,idisp,& & mpi_integer,icomm,info) - call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,& + call mpi_allgatherv(bcoo%ja,ndx,mpi_integer,ac_coo%ja,nzbr,idisp,& & mpi_integer,icomm,info) if(info /= psb_success_) then info=-1 call psb_errpush(info,name) goto 9999 end if - - p%ac%m = ntaggr - p%ac%k = ntaggr - p%ac%infoa(psb_nnz_) = nzac - p%ac%fida='COO' - p%ac%descra='GUN' - call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_free') - goto 9999 - end if + call ac_coo%set_nzeros(nzac) + call ac_coo%set_dupl(psb_dupl_add_) + call ac_coo%fix(info) + call p%ac%mv_from(ac_coo) else if (p%iprcparm(mld_coarse_mat_) == mld_distr_mat_) then call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_sp_clone(b,p%ac,info) + call p%ac%mv_from(bcoo) if(info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Build ac, desc_ac') goto 9999 - end if - call psb_sp_free(b,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_free') - goto 9999 - end if + end if + else info = psb_err_internal_error_ call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_') goto 9999 end if + call bcoo%free() + deallocate(nzbr,idisp) - - call psb_spcnv(p%ac,info,afmt='csr',dupl=psb_dupl_add_) + + call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') + call psb_errpush(psb_err_from_subroutine_,name,a_err='cscnv') goto 9999 end if + call am1%mv_from(acoo1) + call am1%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info == psb_success_) call am2%mv_from(acoo2) + if (info == psb_success_) call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) ! ! Copy the prolongation/restriction matrices into the descriptor map. ! am2 => PR^T i.e. restriction operator ! am1 => PR i.e. prolongation operator ! - p%map = psb_linmap(psb_map_aggr_,desc_a,& + if (info == psb_success_) & + & p%map = psb_linmap(psb_map_aggr_,desc_a,& & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call psb_sp_free(am1,info) - if (info == psb_success_) call psb_sp_free(am2,info) + if (info == psb_success_) call am1%free() + if (info == psb_success_) call am2%free() if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build') goto 9999 end if diff --git a/mlprec/mld_saggrmat_smth_asb.F90 b/mlprec/mld_saggrmat_smth_asb.F90 index b576af01..e976ba8e 100644 --- a/mlprec/mld_saggrmat_smth_asb.F90 +++ b/mlprec/mld_saggrmat_smth_asb.F90 @@ -121,11 +121,12 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) type(psb_sspmat_type) :: b integer, allocatable :: nzbr(:), idisp(:) integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& - & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF + & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw integer ::ictxt,np,me, err_act, icomm character(len=20) :: name - type(psb_sspmat_type) :: am1,am2, af - type(psb_sspmat_type) :: am3,am4 + type(psb_sspmat_type) :: am1,am2, am3, am4 + type(psb_s_coo_sparse_mat) :: acoo1, acoo2, acoof, acoo3,acoo4, bcoo, cootmp + type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsrf, acsr3,acsr4, bcsr real(psb_spk_), allocatable :: adiag(:) logical :: ml_global_nmb, filter_mat integer :: debug_level, debug_unit @@ -145,14 +146,6 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_info(ictxt, me, np) - - call psb_nullify_sp(b) - call psb_nullify_sp(am3) - call psb_nullify_sp(am4) - call psb_nullify_sp(am1) - call psb_nullify_sp(am2) - call psb_nullify_sp(AF) - nglob = psb_cd_get_global_rows(desc_a) nrow = psb_cd_get_local_rows(desc_a) ncol = psb_cd_get_local_cols(desc_a) @@ -201,7 +194,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! Get the diagonal D - call psb_sp_getdiag(a,adiag,info) + call a%get_diag(adiag,info) if (info == psb_success_) & & call psb_halo(adiag,desc_a,info) @@ -211,85 +204,69 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - am4%fida='COO' - am4%m=ncol - if (ml_global_nmb) then - am4%k=ntaggr - call psb_sp_all(ncol,ntaggr,am4,ncol,info) - else - am4%k=naggr - call psb_sp_all(ncol,naggr,am4,ncol,info) - endif - - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spall') - goto 9999 - end if - if (ml_global_nmb) then + call acoo4%allocate(ncol,ntaggr,ncol) do i=1,ncol - am4%aspk(i) = sone - am4%ia1(i) = i - am4%ia2(i) = ilaggr(i) + acoo4%val(i) = done + acoo4%ia(i) = i + acoo4%ja(i) = ilaggr(i) end do - am4%infoa(psb_nnz_) = ncol - else + call acoo4%set_nzeros(ncol) + else + call acoo4%allocate(ncol,naggr,ncol) do i=1,nrow - am4%aspk(i) = sone - am4%ia1(i) = i - am4%ia2(i) = ilaggr(i) + acoo4%val(i) = done + acoo4%ia(i) = i + acoo4%ja(i) = ilaggr(i) end do - am4%infoa(psb_nnz_) = nrow + call acoo4%set_nzeros(nrow) endif + call acoo4%set_dupl(psb_dupl_add_) + + call acsr4%mv_from_coo(acoo4,info) + if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) - - call psb_spcnv(am4,info,afmt='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call psb_spcnv(a,am3,info,afmt='csr',dupl=psb_dupl_add_) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & ' Initial copies done.' - + if (filter_mat) then ! ! Build the filtered matrix Af from A ! - call psb_spcnv(a,af,info,afmt='csr',dupl=psb_dupl_add_) + if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_) do i=1,nrow tmp = szero jd = -1 - do j=af%ia2(i),af%ia2(i+1)-1 - if (af%ia1(j) == i) jd = j - if (abs(af%aspk(j)) < theta*sqrt(abs(adiag(i)*adiag(af%ia1(j))))) then - tmp=tmp+af%aspk(j) - af%aspk(j)=szero + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) jd = j + if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then + tmp=tmp+acsrf%val(j) + acsrf%val(j)=szero endif enddo if (jd == -1) then write(0,*) 'Wrong input: we need the diagonal!!!!', i else - af%aspk(jd)=af%aspk(jd)-tmp + acsrf%val(jd)=acsrf%val(jd)-tmp end if enddo ! Take out zeroed terms - call psb_spcnv(af,info,afmt='coo') + call acsrf%mv_to_coo(acoof,info) k = 0 - do j=1,psb_sp_get_nnzeros(af) - if ((af%aspk(j) /= szero) .or. (af%ia1(j) == af%ia2(j))) then + do j=1,acoof%get_nzeros() + if ((acoof%val(j) /= dzero) .or. (acoof%ia(j) == acoof%ja(j))) then k = k + 1 - af%aspk(k) = af%aspk(j) - af%ia1(k) = af%ia1(j) - af%ia2(k) = af%ia2(j) + acoof%val(k) = acoof%val(j) + acoof%ia(k) = acoof%ia(j) + acoof%ja(k) = acoof%ja(j) end if end do -!!$ write(debug_unit,*) me,' ',trim(name),' Non zeros from filtered matrix:',k,af%m,af%k - call psb_sp_setifld(k,psb_nnz_,af,info) - call psb_spcnv(af,info,afmt='csr') + call acoof%set_nzeros(k) + call acoof%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(acoof,info) end if @@ -301,9 +278,8 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if end do - if (filter_mat) call psb_sp_scal(adiag,af,info) - - call psb_sp_scal(adiag,am3,info) + if (filter_mat) call acsrf%scal(adiag,info) + if (info == psb_success_) call acsr3%scal(adiag,info) if (info /= psb_success_) goto 9999 @@ -316,30 +292,25 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! This only works with CSR ! - if (psb_toupper(am3%fida) == 'CSR') then - anorm = szero - dg = sone - do i=1,am3%m - tmp = szero - do j=am3%ia2(i),am3%ia2(i+1)-1 - if (am3%ia1(j) <= am3%m) then - tmp = tmp + abs(am3%aspk(j)) - endif - if (am3%ia1(j) == i ) then - dg = abs(am3%aspk(j)) - end if - end do - anorm = max(anorm,tmp/dg) - enddo - - call psb_amx(ictxt,anorm) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='this section only CSR') - goto 9999 - endif + anorm = szero + dg = sone + nrw = acsr3%get_nrows() + do i=1, nrw + tmp = szero + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) <= nrw) then + tmp = tmp + abs(acsr3%val(j)) + endif + if (acsr3%ja(j) == i ) then + dg = abs(acsr3%val(j)) + end if + end do + anorm = max(anorm,tmp/dg) + enddo + + call psb_amx(ictxt,anorm) else - anorm = psb_spnrmi(am3,desc_a,info) + anorm = acsr3%csnmi() endif if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') @@ -368,20 +339,15 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Build the smoothed prolongator using the filtered matrix ! - if (psb_toupper(af%fida) == 'CSR') then - do i=1,af%m - do j=af%ia2(i),af%ia2(i+1)-1 - if (af%ia1(j) == i) then - af%aspk(j) = sone - omega*af%aspk(j) - else - af%aspk(j) = - omega*af%aspk(j) - end if - end do + do i=1,acsrf%get_nrows() + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) then + acsrf%val(j) = sone - omega*acsrf%val(j) + else + acsrf%val(j) = - omega*acsrf%val(j) + end if end do - else - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AF storage format') - goto 9999 - end if + end do if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -389,39 +355,35 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*Af)Ptilde + ! acsrm1 = (I-w*D*Af)Ptilde ! Doing it this way means to consider diag(Af_i) ! ! - call psb_symbmm(af,am4,am1,info) + call psb_symbmm(acsrf,acsr4,acsr1,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(af,am4,am1) + call psb_numbmm(acsrf,acsr4,acsr1) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 1' + else ! ! Build the smoothed prolongator using the original matrix ! - if (psb_toupper(am3%fida) == 'CSR') then - do i=1,am3%m - do j=am3%ia2(i),am3%ia2(i+1)-1 - if (am3%ia1(j) == i) then - am3%aspk(j) = sone - omega*am3%aspk(j) - else - am3%aspk(j) = - omega*am3%aspk(j) - end if - end do + do i=1,acsr3%get_nrows() + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) == i) then + acsr3%val(j) = sone - omega*acsr3%val(j) + else + acsr3%val(j) = - omega*acsr3%val(j) + end if end do - else - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') - goto 9999 - end if + end do if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -429,30 +391,27 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*A)Ptilde + ! acsrm1 = (I-w*D*A)Ptilde ! Doing it this way means to consider diag(A_i) ! ! - call psb_symbmm(am3,am4,am1,info) + call psb_symbmm(acsr3,acsr4,acsr1,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(am3,am4,am1) + call psb_numbmm(acsr3,acsr4,acsr1) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 1' end if + call acsr4%free() + call acsr1%set_dupl(psb_dupl_add_) - call psb_sp_free(am4,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_free') - goto 9999 - end if - + call am1%mv_from(acsr1) if (ml_global_nmb) then ! ! Now we have to gather the halo of am1, and add it to itself @@ -461,7 +420,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_sphalo(am1,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.) if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) - if (info == psb_success_) call psb_sp_free(am4,info) + if (info == psb_success_) call am4%free() else call psb_rwextd(ncol,am1,info) endif @@ -479,32 +438,35 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_numbmm(a,am1,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 2' + & 'Done NUMBMM 2',p%iprcparm(mld_aggr_kind_), mld_smooth_prol_ if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then - call psb_transp(am1,am2,fmt='COO') - nzl = am2%infoa(psb_nnz_) + call am2%transp(am1) + call am2%mv_to(acoo2) + nzl = acoo2%get_nzeros() i=0 ! ! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! do k=1, nzl - if ((naggrm1 < am2%ia1(k)) .and.(am2%ia1(k) <= naggrp1)) then + if ((naggrm1 < acoo2%ia(k)) .and.(acoo2%ia(k) <= naggrp1)) then i = i+1 - am2%aspk(i) = am2%aspk(k) - am2%ia1(i) = am2%ia1(k) - am2%ia2(i) = am2%ia2(k) + acoo2%val(i) = acoo2%val(k) + acoo2%ia(i) = acoo2%ia(k) + acoo2%ja(i) = acoo2%ja(k) end if end do - am2%infoa(psb_nnz_) = i - call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_) + call acoo2%set_nzeros(i) + call acoo2%trim() + call am2%mv_from(acoo2) + call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv am2') goto 9999 end if else - call psb_transp(am1,am2) + call am2%transp(am1) endif if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -515,7 +477,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_sphalo(am3,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.) if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) - if (info == psb_success_) call psb_sp_free(am4,info) + if (info == psb_success_) call am4%free() else if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then call psb_rwextd(ncol,am3,info) endif @@ -530,8 +492,8 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) & 'starting symbmm 3' call psb_symbmm(am2,am3,b,info) if (info == psb_success_) call psb_numbmm(am2,am3,b) - if (info == psb_success_) call psb_sp_free(am3,info) - if (info == psb_success_) call psb_spcnv(b,info,afmt='coo',dupl=psb_dupl_add_) + if (info == psb_success_) call am3%free() + if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Build b = am2 x am3') goto 9999 @@ -547,14 +509,15 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) case(mld_distr_mat_) - call psb_sp_clone(b,p%ac,info) - nzac = p%ac%infoa(psb_nnz_) - nzl = p%ac%infoa(psb_nnz_) + nzac = b%get_nzeros() + nzl = nzac + call b%mv_to(bcoo) + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,p%ac%ia1,p%ac%ia2,p%desc_ac,info) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(p%ac%ia1(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(p%ac%ia2(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Creating p%desc_ac and converting ac') goto 9999 @@ -562,14 +525,12 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Assembld aux descr. distr.' + call p%ac%mv_from(bcoo) + call p%ac%set_nrows(psb_cd_get_local_rows(p%desc_ac)) + call p%ac%set_ncols(psb_cd_get_local_cols(p%desc_ac)) + call p%ac%set_asb() - p%ac%m=psb_cd_get_local_rows(p%desc_ac) - p%ac%k=psb_cd_get_local_cols(p%desc_ac) - p%ac%fida='COO' - p%ac%descra='GUN' - - call psb_sp_free(b,info) if (info == psb_success_) deallocate(nzbr,idisp,stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') @@ -577,26 +538,31 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if if (np>1) then - nzl = psb_sp_get_nnzeros(am1) - call psb_glob_to_loc(am1%ia1(1:nzl),p%desc_ac,info,'I') + call am1%mv_to(acsr1) + nzl = acsr1%get_nzeros() + call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I') if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc') goto 9999 end if + call am1%mv_from(acsr1) endif - am1%k=psb_cd_get_local_cols(p%desc_ac) + call am1%set_ncols(psb_cd_get_local_cols(p%desc_ac)) if (np>1) then - call psb_spcnv(am2,info,afmt='coo',dupl=psb_dupl_add_) - nzl = am2%infoa(psb_nnz_) - if (info == psb_success_) call psb_glob_to_loc(am2%ia1(1:nzl),p%desc_ac,info,'I') - if (info == psb_success_) call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_) + call am2%cscnv(info,type='coo',dupl=psb_dupl_add_) + call am2%mv_to(acoo2) + nzl = acoo2%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo2%ia(1:nzl),p%desc_ac,info,'I') + call acoo2%set_dupl(psb_dupl_add_) + if (info == psb_success_) call am2%mv_from(acoo2) + if (info == psb_success_) call am2%cscnv(info,type='csr') if(info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') goto 9999 end if end if - am2%m=psb_cd_get_local_cols(p%desc_ac) + call am2%set_nrows(psb_cd_get_local_cols(p%desc_ac)) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -606,39 +572,43 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - nzbr(:) = 0 - nzbr(me+1) = b%infoa(psb_nnz_) - - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - if (info == psb_success_) call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info) - if (info /= psb_success_) goto 9999 - - do ip=1,np - idisp(ip) = sum(nzbr(1:ip-1)) - enddo - ndx = nzbr(me+1) - - call mpi_allgatherv(b%aspk,ndx,mpi_real,p%ac%aspk,nzbr,idisp,& - & mpi_real,icomm,info) - if (info == psb_success_) call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,& - & mpi_integer,icomm,info) - if (info == psb_success_) call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,& - & mpi_integer,icomm,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') - goto 9999 - end if + if (.false.) then + nzbr(:) = 0 + nzbr(me+1) = b%get_nzeros() + call b%mv_to(bcoo) + call psb_sum(ictxt,nzbr(1:np)) + nzac = sum(nzbr) + if (info == psb_success_) call cootmp%allocate(ntaggr,ntaggr,nzac) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + + call mpi_allgatherv(bcoo%val,ndx,mpi_real,& + & cootmp%val,nzbr,idisp,& + & mpi_double_precision,icomm,info) + if (info == psb_success_) call mpi_allgatherv(bcoo%ia,ndx,mpi_integer,& + & cootmp%ia,nzbr,idisp,& + & mpi_integer,icomm,info) + if (info == psb_success_) call mpi_allgatherv(bcoo%ja,ndx,mpi_integer,& + & cootmp%ja,nzbr,idisp,& + & mpi_integer,icomm,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call bcoo%free() - p%ac%m = ntaggr - p%ac%k = ntaggr - p%ac%infoa(psb_nnz_) = nzac - p%ac%fida='COO' - p%ac%descra='GUN' - call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_) + call cootmp%set_nzeros(nzac) + call cootmp%set_dupl(psb_dupl_add_) + call p%ac%mv_from(cootmp) + else + call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) + endif if(info /= psb_success_) goto 9999 - call psb_sp_free(b,info) if(info /= psb_success_) goto 9999 deallocate(nzbr,idisp,stat=info) @@ -660,10 +630,9 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) case(mld_distr_mat_) - call psb_sp_clone(b,p%ac,info) + call psb_move_alloc(b,p%ac,info) if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_sp_free(b,info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Build desc_ac, ac') goto 9999 @@ -678,47 +647,14 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') goto 9999 end if + call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) + if(info /= psb_success_) goto 9999 - nzbr(:) = 0 - nzbr(me+1) = b%infoa(psb_nnz_) - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_all') - goto 9999 - end if - do ip=1,np - idisp(ip) = sum(nzbr(1:ip-1)) - enddo - ndx = nzbr(me+1) - - call mpi_allgatherv(b%aspk,ndx,mpi_real,p%ac%aspk,nzbr,idisp,& - & mpi_real,icomm,info) - if (info == psb_success_) call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,& - & mpi_integer,icomm,info) - if (info == psb_success_) call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,& - & mpi_integer,icomm,info) + deallocate(nzbr,idisp,stat=info) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') - goto 9999 - end if - - - p%ac%m = ntaggr - p%ac%k = ntaggr - p%ac%infoa(psb_nnz_) = nzac - p%ac%fida='COO' - p%ac%descra='GUN' - call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - call psb_sp_free(b,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) goto 9999 end if @@ -742,7 +678,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end select - call psb_spcnv(p%ac,info,afmt='csr',dupl=psb_dupl_add_) + call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') goto 9999 @@ -755,8 +691,8 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) ! p%map = psb_linmap(psb_map_aggr_,desc_a,& & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call psb_sp_free(am1,info) - if (info == psb_success_) call psb_sp_free(am2,info) + if (info == psb_success_) call am1%free() + if (info == psb_success_) call am2%free() if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') goto 9999 diff --git a/mlprec/mld_sas_aply.f90 b/mlprec/mld_sas_aply.f90 deleted file mode 100644 index f785e7a6..00000000 --- a/mlprec/mld_sas_aply.f90 +++ /dev/null @@ -1,407 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,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. -!!$ -!!$ -! File: mld_sas_aply.f90 -! -! Subroutine: mld_sas_aply -! Version: real -! -! This routine applies the Additive Schwarz preconditioner by computing -! -! Y = beta*Y + alpha*op(K^(-1))*X, -! where -! - K is the base preconditioner, stored in prec, -! - op(K^(-1)) is K^(-1) or its transpose, according to the value of trans, -! - X and Y are vectors, -! - alpha and beta are scalars. -! -! -! Arguments: -! alpha - real(psb_spk_), input. -! The scalar alpha. -! prec - type(mld_sbaseprec_type), input. -! The base preconditioner data structure containing the local part -! of the preconditioner K. -! x - real(psb_spk_), dimension(:), input. -! The local part of the vector X. -! beta - real(psb_spk_), input. -! The scalar beta. -! y - real(psb_spk_), dimension(:), input/output. -! The local part of the vector Y. -! desc_data - type(psb_desc_type), input. -! The communication descriptor associated to the matrix to be -! preconditioned. -! trans - character, optional. -! If trans='N','n' then op(K^(-1)) = K^(-1); -! if trans='T','t' then op(K^(-1)) = K^(-T) (transpose of K^(-1)). -! work - real(psb_spk_), dimension (:), optional, target. -! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data). -! info - integer, output. -! Error code. -! -subroutine mld_sas_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - - use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_sas_aply - - implicit none - - ! Arguments - type(psb_desc_type),intent(in) :: desc_data - type(mld_sbaseprec_type), intent(in) :: prec - real(psb_spk_),intent(in) :: x(:) - real(psb_spk_),intent(inout) :: y(:) - real(psb_spk_),intent(in) :: alpha,beta - character(len=1) :: trans - real(psb_spk_),target :: work(:) - integer, intent(out) :: info - - ! Local variables - integer :: n_row,n_col, int_err(5), nrow_d - real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) - integer :: ictxt,np,me,isz, err_act - character(len=20) :: name, ch_err - character :: trans_ - - name='mld_sas_aply' - info = psb_success_ - call psb_erractionsave(err_act) - - ictxt = psb_cd_get_context(desc_data) - - call psb_info(ictxt, me, np) - - trans_ = psb_toupper(trans) - - select case(prec%iprcparm(mld_smoother_type_)) - - case(mld_bjac_) - - call mld_sub_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_sub_aply' - goto 9999 - end if - - case(mld_as_) - ! - ! Additive Schwarz preconditioner - ! - - if ((prec%iprcparm(mld_sub_ovr_) == 0).or.(np==1)) then - ! - ! Shortcut: this fixes performance for RAS(0) == BJA - ! - call mld_sub_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_sub_aply' - goto 9999 - end if - - else - ! - ! Overlap > 0 - ! - - n_row = psb_cd_get_local_rows(prec%desc_data) - n_col = psb_cd_get_local_cols(prec%desc_data) - nrow_d = psb_cd_get_local_rows(desc_data) - 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 - - tx(1:nrow_d) = x(1:nrow_d) - tx(nrow_d+1:isz) = szero - - select case(trans_) - case('N') - ! - ! Get the overlap entries of tx (tx == x) - ! - if (prec%iprcparm(mld_sub_restr_) == psb_halo_) then - call psb_halo(tx,prec%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 (prec%iprcparm(mld_sub_restr_) /= psb_none_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_') - goto 9999 - end if - - ! - ! If required, reorder tx according to the row/column permutation of the - ! local extended matrix, stored into the permutation vector prec%perm - ! - if (prec%iprcparm(mld_sub_ren_)>0) then - call psb_gelp('n',prec%perm,tx,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_gelp' - goto 9999 - end if - endif - - ! - ! Apply to tx the block-Jacobi preconditioner/solver (multiple sweeps of the - ! block-Jacobi solver can be applied at the coarsest level of a multilevel - ! preconditioner). The resulting vector is ty. - ! - call mld_sub_aply(sone,prec,tx,szero,ty,prec%desc_data,trans_,aux,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_bjac_aply' - goto 9999 - end if - - ! - ! Apply to ty the inverse permutation of prec%perm - ! - if (prec%iprcparm(mld_sub_ren_)>0) then - call psb_gelp('n',prec%invperm,ty,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_gelp' - goto 9999 - end if - endif - - select case (prec%iprcparm(mld_sub_prol_)) - - case(psb_none_) - ! - ! Would work anyway, but since it is supposed to do nothing ... - ! call psb_ovrl(ty,prec%desc_data,info,& - ! & update=prec%iprcparm(mld_sub_prol_),work=aux) - - - case(psb_sum_,psb_avg_) - ! - ! Update the overlap of ty - ! - call psb_ovrl(ty,prec%desc_data,info,& - & update=prec%iprcparm(mld_sub_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 - ! - - select case (prec%iprcparm(mld_sub_prol_)) - - case(psb_none_) - ! - ! Do nothing - - case(psb_sum_) - ! - ! The transpose of sum is halo - ! - call psb_halo(tx,prec%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,prec%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,prec%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 - - ! - ! If required, reorder tx according to the row/column permutation of the - ! local extended matrix, stored into the permutation vector prec%perm - ! - if (prec%iprcparm(mld_sub_ren_)>0) then - call psb_gelp('n',prec%perm,tx,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_gelp' - goto 9999 - end if - endif - - ! - ! Apply to tx the block-Jacobi preconditioner/solver (multiple sweeps of the - ! block-Jacobi solver can be applied at the coarsest level of a multilevel - ! preconditioner). The resulting vector is ty. - ! - call mld_sub_aply(sone,prec,tx,szero,ty,prec%desc_data,trans_,aux,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_bjac_aply' - goto 9999 - end if - - ! - ! Apply to ty the inverse permutation of prec%perm - ! - if (prec%iprcparm(mld_sub_ren_)>0) then - call psb_gelp('n',prec%invperm,ty,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_gelp' - goto 9999 - end if - endif - - ! - ! With transpose, we have to do it here - ! - if (prec%iprcparm(mld_sub_restr_) == psb_halo_) then - call psb_ovrl(ty,prec%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 (prec%iprcparm(mld_sub_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 - - ! - ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) - ! - call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - - - 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 - end if - - case default - - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_smoother_type_') - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine mld_sas_aply - diff --git a/mlprec/mld_sas_bld.f90 b/mlprec/mld_sas_bld.f90 deleted file mode 100644 index c5482c5d..00000000 --- a/mlprec/mld_sas_bld.f90 +++ /dev/null @@ -1,287 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,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. -!!$ -!!$ -! File: mld_sas_bld.f90 -! -! Subroutine: mld_sas_bld -! Version: real -! -! This routine builds Additive Schwarz (AS) preconditioners. If the AS -! preconditioner is actually the block-Jacobi one, the routine makes only a -! copy of the descriptor of the original matrix and then calls mld_fact_bld -! to perform an LU or ILU factorization of the diagonal blocks of the -! distributed matrix. -! -! -! Arguments: -! a - type(psb_dspmat_type), input. -! The sparse matrix structure containing the local part of the -! matrix to be preconditioned. -! desc_a - type(psb_desc_type), input. -! The communication descriptor of the sparse matrix a. -! p - type(mld_sbaseprec_type), input/output. -! The 'base preconditioner' data structure containing the local -! part of the preconditioner or solver to be built. -! upd - character, input. -! If upd='F' then the preconditioner is built from scratch; -! if upd=T' then the matrix to be preconditioned has the same -! sparsity pattern of a matrix that has been previously -! preconditioned, hence some information is reused in building -! the new preconditioner. -! info - integer, output. -! Error code. -! -subroutine mld_sas_bld(a,desc_a,p,upd,info) - - use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_sas_bld - - Implicit None - - ! Arguments - type(psb_sspmat_type), intent(in), target :: a - Type(psb_desc_type), Intent(in) :: desc_a - type(mld_sbaseprec_type), intent(inout) :: p - character, intent(in) :: upd - integer, intent(out) :: info - - ! Local variables - integer :: ptype,novr - integer :: icomm - Integer :: np,me,nnzero,ictxt, int_err(5),& - & tot_recv, n_row,n_col,nhalo, err_act, data_ - type(psb_sspmat_type) :: blck - integer :: debug_level, debug_unit - character(len=20) :: name, ch_err - - name='mld_as_bld' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - If (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' start ', upd - ictxt = psb_cd_get_context(desc_a) - icomm = psb_cd_get_mpic(desc_a) - - Call psb_info(ictxt, me, np) - - tot_recv=0 - - n_row = psb_cd_get_local_rows(desc_a) - n_col = psb_cd_get_local_cols(desc_a) - nnzero = psb_sp_get_nnzeros(a) - nhalo = n_col-n_row - ptype = p%iprcparm(mld_smoother_type_) - novr = p%iprcparm(mld_sub_ovr_) - - select case (ptype) - - case(mld_bjac_) - ! - ! Block Jacobi - ! - data_ = psb_no_comm_ - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Calling desccpy' - if (upd == 'F') then - call psb_cdcpy(desc_a,p%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 psb_sp_all(0,0,blck,1,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - blck%fida = 'COO' - blck%infoa(psb_nnz_) = 0 - - call mld_fact_bld(a,p,upd,info,blck=blck) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_fact_bld' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - case(mld_as_) - ! - ! Additive Schwarz - ! - if (novr < 0) then - info=psb_err_invalid_ovr_num_ - int_err(1)=novr - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - if ((novr == 0).or.(np == 1)) then - ! - ! Actually, this is just block Jacobi - ! - data_ = psb_no_comm_ - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Calling desccpy' - if (upd == 'F') then - call psb_cdcpy(desc_a,p%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 psb_sp_all(0,0,blck,1,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - blck%fida = 'COO' - blck%infoa(psb_nnz_) = 0 - - else - - If (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,p%desc_data,info,extype=psb_ovt_asov_) - if(debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' From cdbldext _:',p%desc_data%matrix_data(psb_n_row_),& - & p%desc_data%matrix_data(psb_n_col_) - - 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 ',blck%fida,blck%m,psb_nnz_,blck%infoa(psb_nnz_) - - ! - ! Retrieve the remote sparse matrix rows required for the AS extended - ! matrix - data_ = psb_comm_ext_ - Call psb_sphalo(a,p%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%fida,blck%m,psb_nnz_,blck%infoa(psb_nnz_) - - End if - - - call mld_fact_bld(a,p,upd,info,blck=blck) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_fact_bld' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case default - - info=psb_err_internal_error_ - ch_err='Invalid ptype' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - - End select - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),'Done' - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then - call psb_error() - return - end if - Return - -End Subroutine mld_sas_bld - diff --git a/mlprec/mld_sbaseprec_aply.f90 b/mlprec/mld_sbaseprec_aply.f90 deleted file mode 100644 index d1574392..00000000 --- a/mlprec/mld_sbaseprec_aply.f90 +++ /dev/null @@ -1,189 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,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. -!!$ -!!$ -! File: mld_sbaseprec_aply.f90 -! -! Subroutine: mld_sbaseprec_aply -! Version: real -! -! This routine applies a base preconditioner by computing -! -! Y = beta*Y + alpha*op(K^(-1))*X, -! where -! - K is the base preconditioner, stored in prec, -! - op(K^(-1)) is K^(-1) or its transpose, according to the value of trans, -! - X and Y are vectors, -! - alpha and beta are scalars. -! -! The routine is used by mld_smlprec_aply, to apply the multilevel preconditioners, -! or directly by mld_sprec_aply, to apply the basic one-level preconditioners (diagonal, -! block-Jacobi or additive Schwarz). It also manages the case of no preconditioning. -! -! -! Arguments: -! alpha - real(psb_spk_), input. -! The scalar alpha. -! prec - type(mld_sbaseprec_type), input. -! The base preconditioner data structure containing the local part -! of the preconditioner K. -! x - real(psb_spk_), dimension(:), input. -! The local part of the vector X. -! beta - real(psb_spk_), input. -! The scalar beta. -! y - real(psb_spk_), dimension(:), input/output. -! The local part of the vector Y. -! desc_data - type(psb_desc_type), input. -! The communication descriptor associated to the matrix to be -! preconditioned. -! trans - character, optional. -! If trans='N','n' then op(K^(-1)) = K^(-1); -! if trans='T','t' then op(K^(-1)) = K^(-T) (transpose of K^(-1)). -! work - real(psb_spk_), dimension (:), optional, target. -! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data). -! info - integer, output. -! Error code. -! -subroutine mld_sbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) - - use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_sbaseprec_aply - - implicit none - - ! Arguments - type(psb_desc_type),intent(in) :: desc_data - type(mld_sbaseprec_type), intent(in) :: prec - real(psb_spk_),intent(in) :: x(:) - real(psb_spk_),intent(inout) :: y(:) - real(psb_spk_),intent(in) :: alpha,beta - character(len=1) :: trans - real(psb_spk_),target :: work(:) - integer, intent(out) :: info - - ! Local variables - real(psb_spk_), pointer :: ww(:) - integer :: ictxt, np, me, err_act - integer :: n_row, int_err(5) - character(len=20) :: name, ch_err - character :: trans_ - - name='mld_sbaseprec_aply' - info = psb_success_ - call psb_erractionsave(err_act) - - ictxt = psb_cd_get_context(desc_data) - - call psb_info(ictxt, me, np) - - trans_= psb_toupper(trans) - select case(trans_) - case('N','T','C') - ! Ok - case default - info=psb_err_iarg_invalid_i_ - int_err(1)=6 - ch_err(2:2)=trans - goto 9999 - end select - - select case(prec%iprcparm(mld_smoother_type_)) - - case(mld_noprec_) - ! - ! No preconditioner - ! - - call psb_geaxpby(alpha,x,beta,y,desc_data,info) - - case(mld_diag_) - ! - ! Diagonal preconditioner - ! - - if (size(work) >= size(x)) then - ww => work - else - allocate(ww(size(x)),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_request_,name,i_err=(/size(x),0,0,0,0/),a_err='real(psb_spk_)') - goto 9999 - end if - end if - - n_row = psb_cd_get_local_rows(desc_data) - ww(1:n_row) = x(1:n_row)*prec%d(1:n_row) - call psb_geaxpby(alpha,ww,beta,y,desc_data,info) - - if (size(work) < size(x)) then - deallocate(ww,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate') - goto 9999 - end if - end if - - case(mld_bjac_,mld_as_) - ! - ! Additive Schwarz preconditioner (including block-Jacobi as special case) - ! - call mld_as_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_as_aply' - goto 9999 - end if - - case default - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_smoother_type_') - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine mld_sbaseprec_aply - diff --git a/mlprec/mld_sbaseprec_bld.f90 b/mlprec/mld_sbaseprec_bld.f90 deleted file mode 100644 index ddf05f2c..00000000 --- a/mlprec/mld_sbaseprec_bld.f90 +++ /dev/null @@ -1,215 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,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. -!!$ -!!$ -! File: mld_sbaseprec_bld.f90 -! -! Subroutine: mld_sbaseprec_bld -! Version: real -! -! This routine builds a 'base preconditioner' related to a matrix A. -! In a multilevel framework, it is called by mld_mlprec_bld to build the -! base preconditioner at each level. -! -! Details on the base preconditioner to be built are stored in the iprcparm -! field of the base preconditioner data structure (for a description of this -! data structure see mld_prec_type.f90). -! -! -! Arguments: -! a - type(psb_sspmat_type). -! The sparse matrix structure containing the local part of the -! matrix A to be preconditioned. -! desc_a - type(psb_desc_type), input. -! The communication descriptor of a. -! p - type(mld_sbaseprec_type), input/output. -! The 'base preconditioner' data structure containing the local -! part of the preconditioner at the selected level. -! info - integer, output. -! Error code. -! upd - character, input, optional. -! If upd='F' then the base preconditioner is built from -! scratch; if upd=T' then the matrix to be preconditioned -! has the same sparsity pattern of a matrix that has been -! previously preconditioned, hence some information is reused -! in building the new preconditioner. -! -subroutine mld_sbaseprec_bld(a,desc_a,p,info,upd) - - use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_sbaseprec_bld - - Implicit None - - ! Arguments - type(psb_sspmat_type), target :: a - type(psb_desc_type), intent(in), target :: desc_a - type(mld_sbaseprec_type),intent(inout) :: p - integer, intent(out) :: info - character, intent(in), optional :: upd - - ! Local variables - Integer :: err, n_row, n_col,ictxt, me,np,mglob, err_act - character :: iupd - integer :: debug_level, debug_unit - character(len=20) :: name, ch_err - - if (psb_get_errstatus() /= 0) return - name = 'mld_sbaseprec_bld' - info=psb_success_ - err=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ictxt = psb_cd_get_context(desc_a) - n_row = psb_cd_get_local_rows(desc_a) - n_col = psb_cd_get_local_cols(desc_a) - mglob = psb_cd_get_global_rows(desc_a) - call psb_info(ictxt, me, np) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),' start' - - - if (present(upd)) then - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),'UPD ', upd - if ((psb_toupper(UPD) == 'F').or.(psb_toupper(UPD) == 'T')) then - IUPD=psb_toupper(UPD) - else - IUPD='F' - endif - else - IUPD='F' - endif - - ! - ! Should add check to ensure all procs have the same... - ! - - call mld_check_def(p%iprcparm(mld_smoother_type_),'base_prec',& - & mld_diag_,is_legal_base_prec) - - - call psb_nullify_desc(p%desc_data) - - select case(p%iprcparm(mld_smoother_type_)) - - case (mld_noprec_) - ! No preconditioner - - ! Do nothing - call psb_cdcpy(desc_a,p%desc_data,info) - 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 - - case (mld_diag_) - ! Diagonal preconditioner - - call mld_diag_bld(a,desc_a,p,info) - if(debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ': out of mld_diag_bld' - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_diag_bld' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case(mld_bjac_,mld_as_) - ! Additive Schwarz preconditioners/smoothers - - call mld_check_def(p%iprcparm(mld_sub_ovr_),'overlap',& - & 0,is_legal_n_ovr) - call mld_check_def(p%iprcparm(mld_sub_restr_),'restriction',& - & psb_halo_,is_legal_restrict) - call mld_check_def(p%iprcparm(mld_sub_prol_),'prolongator',& - & psb_none_,is_legal_prolong) - call mld_check_def(p%iprcparm(mld_sub_ren_),'renumbering',& - & mld_renum_none_,is_legal_renum) - call mld_check_def(p%iprcparm(mld_sub_solve_),'fact',& - & mld_ilu_n_,is_legal_ml_fact) - - ! Set parameters for using SuperLU_dist on the local submatrices - if (p%iprcparm(mld_sub_solve_) == mld_sludist_) then - p%iprcparm(mld_sub_ovr_) = 0 - p%iprcparm(mld_smoother_sweeps_) = 1 - end if - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ': Calling mld_as_bld' - - ! Build the local part of the base preconditioner/smoother - call mld_as_bld(a,desc_a,p,iupd,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='mld_as_bld') - goto 9999 - end if - - case default - - info=psb_err_internal_error_ - ch_err='Unknown mld_smoother_type_' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - - end select - - p%iprcparm(mld_prec_status_) = mld_prec_built_ - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),': Done' - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act.eq.psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine mld_sbaseprec_bld - diff --git a/mlprec/mld_scoarse_bld.f90 b/mlprec/mld_scoarse_bld.f90 index 560a6819..f0563a1b 100644 --- a/mlprec/mld_scoarse_bld.f90 +++ b/mlprec/mld_scoarse_bld.f90 @@ -79,11 +79,9 @@ subroutine mld_scoarse_bld(a,desc_a,p,info) integer, intent(out) :: info ! Local variables - type(psb_desc_type) :: desc_ac - type(psb_sspmat_type) :: ac - character(len=20) :: name - integer :: ictxt, np, me, err_act - integer, allocatable :: ilaggr(:), nlaggr(:) + character(len=20) :: name + integer :: ictxt, np, me, err_act + integer, allocatable :: ilaggr(:), nlaggr(:) name='mld_scoarse_bld' if (psb_get_errstatus().ne.0) return @@ -125,7 +123,8 @@ subroutine mld_scoarse_bld(a,desc_a,p,info) ! call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),p%rprcparm(mld_aggr_thresh_),& & a,desc_a,ilaggr,nlaggr,info) - if(info /= psb_success_) then + + if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmap_bld') goto 9999 end if @@ -136,6 +135,7 @@ subroutine mld_scoarse_bld(a,desc_a,p,info) ! algorithm specified by p%iprcparm(mld_aggr_kind_) ! call mld_aggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) + if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_asb') goto 9999 diff --git a/mlprec/mld_silu0_fact.f90 b/mlprec/mld_silu0_fact.f90 index dbc621b8..2094a7c1 100644 --- a/mlprec/mld_silu0_fact.f90 +++ b/mlprec/mld_silu0_fact.f90 @@ -99,10 +99,10 @@ ! greater than 0. If the overlap is 0 or the matrix has been reordered ! (see mld_fact_bld), then blck is empty. ! -subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck) +subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck,upd) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_silu0_fact + use mld_inner_mod!, mld_protect_name => mld_silu0_fact implicit none @@ -113,11 +113,14 @@ subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck) real(psb_spk_), intent(inout) :: d(:) integer, intent(out) :: info type(psb_sspmat_type),intent(in), optional, target :: blck + character, intent(in), optional :: upd ! Local variables - integer :: l1, l2,m,err_act + integer :: l1, l2, m, err_act type(psb_sspmat_type), pointer :: blck_ - character(len=20) :: name, ch_err + type(psb_s_csr_sparse_mat) :: ll, uu + character :: upd_ + character(len=20) :: name, ch_err name='mld_silu0_fact' info = psb_success_ @@ -130,28 +133,36 @@ subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck) blck_ => blck else allocate(blck_,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - call psb_nullify_sp(blck_) ! Probably pointless. - call psb_sp_all(0,0,blck_,1,info) - if(info.ne.0) then + if (info == psb_success_) call blck_%csall(0,0,info,1) + if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='psb_sp_all' + ch_err='csall' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - - blck_%m=0 endif + if (present(upd)) then + upd_ = psb_toupper(upd) + else + upd_ = 'F' + end if + + m = a%get_nrows() + blck_%get_nrows() + if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& + & (m > size(d)) ) then + write(0,*) 'Wrong allocation status for L,D,U? ',& + & l%get_nrows(),size(d),u%get_nrows() + info = -1 + return + end if + call l%mv_to(ll) + call u%mv_to(uu) ! ! Compute the ILU(0) or the MILU(0) factorization, depending on ialg ! - call mld_silu0_factint(ialg,m,a%m,a,blck_%m,blck_,& - & d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) + call mld_silu0_factint(ialg,a,blck_,& + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,info) if(info.ne.0) then info=psb_err_from_subroutine_ ch_err='mld_silu0_factint' @@ -162,24 +173,22 @@ subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck) ! ! Store information on the L and U sparse matrices ! - l%infoa(1) = l1 - l%fida = 'CSR' - l%descra = 'TLU' - u%infoa(1) = l2 - u%fida = 'CSR' - u%descra = 'TUU' - l%m = m - l%k = m - u%m = m - u%k = m - + call l%mv_from(ll) + call l%set_triangle() + call l%set_unit() + call l%set_lower() + call u%mv_from(uu) + call u%set_triangle() + call u%set_unit() + call u%set_upper() + ! ! Nullify pointer / deallocate memory ! if (present(blck)) then blck_ => null() else - call psb_sp_free(blck_,info) + call blck_%free() if(info.ne.0) then info=psb_err_from_subroutine_ ch_err='psb_sp_free' @@ -277,24 +286,25 @@ contains ! info - integer, output. ! Error code. ! - subroutine mld_silu0_factint(ialg,m,ma,a,mb,b,& - & d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info) + subroutine mld_silu0_factint(ialg,a,b,& + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info) implicit none ! Arguments - integer, intent(in) :: ialg + integer, intent(in) :: ialg type(psb_sspmat_type),intent(in) :: a,b - integer,intent(inout) :: m,l1,l2,info - integer, intent(in) :: ma,mb - integer, dimension(:), intent(inout) :: lia1,lia2,uia1,uia2 - real(psb_spk_), dimension(:),intent(inout) :: laspk,uaspk,d + integer,intent(inout) :: l1,l2,info + integer, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) + real(psb_spk_), intent(inout) :: lval(:),uval(:),d(:) + character, intent(in) :: upd ! Local variables - integer :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act + integer :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act, m + integer :: ma,mb real(psb_spk_) :: dia,temp integer, parameter :: nrb=16 - type(psb_sspmat_type) :: trw + type(psb_s_coo_sparse_mat) :: trw integer :: int_err(5) character(len=20) :: name, ch_err @@ -302,6 +312,8 @@ contains if(psb_get_errstatus().ne.0) return info=psb_success_ call psb_erractionsave(err_act) + ma = a%get_nrows() + mb = b%get_nrows() select case(ialg) case(mld_ilu_n_,mld_milu_n_) @@ -312,154 +324,152 @@ contains goto 9999 end select - call psb_nullify_sp(trw) - trw%m=0 - trw%k=0 - - call psb_sp_all(trw,1,info) - if(info.ne.0) then + call trw%allocate(0,0,1) + if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_sp_all' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - - lia2(1) = 1 - uia2(1) = 1 - l1 = 0 - l2 = 0 m = ma+mb - ! - ! Cycle over the matrix rows - ! - do i = 1, m + if (psb_toupper(upd) == 'F' ) then + lirp(1) = 1 + uirp(1) = 1 + l1 = 0 + l2 = 0 + + ! + ! Cycle over the matrix rows + ! + do i = 1, m d(i) = szero - if (i <= ma) then - ! - ! Copy the i-th local row of the matrix, stored in a, - ! into laspk/d(i)/uaspk - ! - call ilu_copyin(i,ma,a,i,1,m,l1,lia1,laspk,& - & d(i),l2,uia1,uaspk,ktrw,trw) - else - ! - ! Copy the i-th local row of the matrix, stored in b - ! (as (i-ma)-th row), into laspk/d(i)/uaspk - ! - call ilu_copyin(i-ma,mb,b,i,1,m,l1,lia1,laspk,& - & d(i),l2,uia1,uaspk,ktrw,trw) - endif + if (i <= ma) then + ! + ! Copy the i-th local row of the matrix, stored in a, + ! into lval/d(i)/uval + ! + call ilu_copyin(i,ma,a,i,1,m,l1,lja,lval,& + & d(i),l2,uja,uval,ktrw,trw,upd) + else + ! + ! Copy the i-th local row of the matrix, stored in b + ! (as (i-ma)-th row), into lval/d(i)/uval + ! + call ilu_copyin(i-ma,mb,b,i,1,m,l1,lja,lval,& + & d(i),l2,uja,uval,ktrw,trw,upd) + endif - lia2(i+1) = l1 + 1 - uia2(i+1) = l2 + 1 + lirp(i+1) = l1 + 1 + uirp(i+1) = l2 + 1 - dia = d(i) - do kk = lia2(i), lia2(i+1) - 1 - ! - ! Compute entry l(i,k) (lower factor L) of the incomplete - ! factorization - ! - temp = laspk(kk) - k = lia1(kk) - laspk(kk) = temp*d(k) - ! - ! Update the rest of row i (lower and upper factors L and U) - ! using l(i,k) - ! - low1 = kk + 1 - low2 = uia2(i) - ! - updateloop: do jj = uia2(k), uia2(k+1) - 1 + dia = d(i) + do kk = lirp(i), lirp(i+1) - 1 ! - j = uia1(jj) + ! Compute entry l(i,k) (lower factor L) of the incomplete + ! factorization ! - if (j < i) then - ! - ! search l(i,*) (i-th row of L) for a matching index j - ! - do ll = low1, lia2(i+1) - 1 - l = lia1(ll) - if (l > j) then - low1 = ll - exit - else if (l == j) then - laspk(ll) = laspk(ll) - temp*uaspk(jj) - low1 = ll + 1 - cycle updateloop - end if - enddo - - else if (j == i) then + temp = lval(kk) + k = lja(kk) + lval(kk) = temp*d(k) + ! + ! Update the rest of row i (lower and upper factors L and U) + ! using l(i,k) + ! + low1 = kk + 1 + low2 = uirp(i) + ! + updateloop: do jj = uirp(k), uirp(k+1) - 1 ! - ! j=i: update the diagonal + j = uja(jj) ! - dia = dia - temp*uaspk(jj) - cycle updateloop + if (j < i) then + ! + ! search l(i,*) (i-th row of L) for a matching index j + ! + do ll = low1, lirp(i+1) - 1 + l = lja(ll) + if (l > j) then + low1 = ll + exit + else if (l == j) then + lval(ll) = lval(ll) - temp*uval(jj) + low1 = ll + 1 + cycle updateloop + end if + enddo + + else if (j == i) then + ! + ! j=i: update the diagonal + ! + dia = dia - temp*uval(jj) + cycle updateloop + ! + else if (j > i) then + ! + ! search u(i,*) (i-th row of U) for a matching index j + ! + do ll = low2, uirp(i+1) - 1 + l = uja(ll) + if (l > j) then + low2 = ll + exit + else if (l == j) then + uval(ll) = uval(ll) - temp*uval(jj) + low2 = ll + 1 + cycle updateloop + end if + enddo + end if ! - else if (j > i) then - ! - ! search u(i,*) (i-th row of U) for a matching index j + ! If we get here we missed the cycle updateloop, which means + ! that this entry does not match; thus we accumulate on the + ! diagonal for MILU(0). ! - do ll = low2, uia2(i+1) - 1 - l = uia1(ll) - if (l > j) then - low2 = ll - exit - else if (l == j) then - uaspk(ll) = uaspk(ll) - temp*uaspk(jj) - low2 = ll + 1 - cycle updateloop - end if - enddo - end if + if (ialg == mld_milu_n_) then + dia = dia - temp*uval(jj) + end if + enddo updateloop + enddo + ! + ! Check the pivot size + ! + if (abs(dia) < s_epstol) then + ! + ! Too small pivot: unstable factorization ! - ! If we get here we missed the cycle updateloop, which means - ! that this entry does not match; thus we accumulate on the - ! diagonal for MILU(0). + info = psb_err_pivot_too_small_ + int_err(1) = i + write(ch_err,'(g20.10)') abs(dia) + call psb_errpush(info,name,i_err=int_err,a_err=ch_err) + goto 9999 + else ! - if (ialg == mld_milu_n_) then - dia = dia - temp*uaspk(jj) - end if - enddo updateloop - enddo - ! - ! Check the pivot size - ! - if (abs(dia) < s_epstol) then - ! - ! Too small pivot: unstable factorization - ! - info = psb_err_pivot_too_small_ - int_err(1) = i - write(ch_err,'(g20.10)') abs(dia) - call psb_errpush(info,name,i_err=int_err,a_err=ch_err) - goto 9999 - else + ! Compute 1/pivot + ! + dia = sone/dia + end if + d(i) = dia ! - ! Compute 1/pivot + ! Scale row i of upper triangle ! - dia = sone/dia - end if - d(i) = dia - ! - ! Scale row i of upper triangle - ! - do kk = uia2(i), uia2(i+1) - 1 - uaspk(kk) = uaspk(kk)*dia + do kk = uirp(i), uirp(i+1) - 1 + uval(kk) = uval(kk)*dia + enddo enddo - enddo - - call psb_sp_free(trw,info) - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) + else + write(0,*) 'Update not implemented ' + info = 31 + call psb_errpush(info,name,i_err=(/13,0,0,0,0/),a_err=upd) goto 9999 + end if + call trw%free() + call psb_erractionrestore(err_act) return @@ -480,13 +490,13 @@ contains ! This routine copies a row of a sparse matrix A, stored in the psb_sspmat_type ! data structure a, into the arrays laspk and uaspk and into the scalar variable ! dia, corresponding to the lower and upper triangles of A and to the diagonal - ! entry of the row, respectively. The entries in laspk and uaspk are stored + ! entry of the row, respectively. The entries in lval and uval are stored ! according to the CSR format; the corresponding column indices are stored in - ! the arrays lia1 and uia1. + ! the arrays lja and uja. ! ! If the sparse matrix is in CSR format, a 'straight' copy is performed; ! otherwise psb_sp_getblk is used to extract a block of rows, which is then - ! copied into laspk, dia, uaspk row by row, through successive calls to + ! copied into lval, dia, uval row by row, through successive calls to ! ilu_copyin. ! ! The routine is used by mld_silu0_factint in the computation of the ILU(0)/MILU(0) @@ -514,23 +524,23 @@ contains ! The output matrix will contain a clipped copy taken from ! a(1:m,jmin:jmax). ! l1 - integer, input/output. - ! Pointer to the last occupied entry of laspk. - ! lia1 - integer, dimension(:), input/output. + ! Pointer to the last occupied entry of lval. + ! lja - integer, dimension(:), input/output. ! The column indices of the nonzero entries of the lower triangle - ! copied in laspk row by row (see mld_silu0_factint), according + ! copied in lval row by row (see mld_dilu0_factint), according ! to the CSR storage format. - ! laspk - real(psb_spk_), dimension(:), input/output. + ! lval - real(psb_spk_), dimension(:), input/output. ! The array where the entries of the row corresponding to the ! lower triangle are copied. ! dia - real(psb_spk_), output. ! The diagonal entry of the copied row. ! l2 - integer, input/output. - ! Pointer to the last occupied entry of uaspk. - ! uia1 - integer, dimension(:), input/output. + ! Pointer to the last occupied entry of uval. + ! uja - integer, dimension(:), input/output. ! The column indices of the nonzero entries of the upper triangle - ! copied in uaspk row by row (see mld_silu0_factint), according + ! copied in uval row by row (see mld_dilu0_factint), according ! to the CSR storage format. - ! uaspk - real(psb_spk_), dimension(:), input/output. + ! uval - real(psb_spk_), dimension(:), input/output. ! The array where the entries of the row corresponding to the ! upper triangle are copied. ! ktrw - integer, input/output. @@ -544,8 +554,8 @@ contains ! until we empty the buffer. Thus we will make a call to psb_sp_getblk ! every nrb calls to copyin. If A is in CSR format it is unused. ! - subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lia1,laspk,& - & dia,l2,uia1,uaspk,ktrw,trw) + subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lja,lval,& + & dia,l2,uja,uval,ktrw,trw,upd) use psb_sparse_mod @@ -553,83 +563,95 @@ contains ! Arguments type(psb_sspmat_type), intent(in) :: a - type(psb_sspmat_type), intent(inout) :: trw + type(psb_s_coo_sparse_mat), intent(inout) :: trw integer, intent(in) :: i,m,jd,jmin,jmax integer, intent(inout) :: ktrw,l1,l2 - integer, intent(inout) :: lia1(:), uia1(:) - real(psb_spk_), intent(inout) :: laspk(:), uaspk(:), dia - + integer, intent(inout) :: lja(:), uja(:) + real(psb_spk_), intent(inout) :: lval(:), uval(:), dia + character, intent(in) :: upd ! Local variables - integer :: k,j,info,irb - integer, parameter :: nrb=16 + integer :: k,j,info,irb, nz + integer, parameter :: nrb=40 character(len=20), parameter :: name='ilu_copyin' character(len=20) :: ch_err if (psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_toupper(upd) == 'F') then - if (psb_toupper(a%fida) == 'CSR') then + select type(aa => a%a) + type is (psb_s_csr_sparse_mat) - ! - ! Take a fast shortcut if the matrix is stored in CSR format - ! + ! + ! Take a fast shortcut if the matrix is stored in CSR format + ! - do j = a%ia2(i), a%ia2(i+1) - 1 - k = a%ia1(j) - ! write(0,*)'KKKKK',k - if ((k < jd).and.(k >= jmin)) then - l1 = l1 + 1 - laspk(l1) = a%aspk(j) - lia1(l1) = k - else if (k == jd) then - dia = a%aspk(j) - else if ((k > jd).and.(k <= jmax)) then - l2 = l2 + 1 - uaspk(l2) = a%aspk(j) - uia1(l2) = k - end if - enddo + do j = aa%irp(i), aa%irp(i+1) - 1 + k = aa%ja(j) + ! write(0,*)'KKKKK',k + if ((k < jd).and.(k >= jmin)) then + l1 = l1 + 1 + lval(l1) = aa%val(j) + lja(l1) = k + else if (k == jd) then + dia = aa%val(j) + else if ((k > jd).and.(k <= jmax)) then + l2 = l2 + 1 + uval(l2) = aa%val(j) + uja(l2) = k + end if + enddo - else + class default - ! - ! Otherwise use psb_sp_getblk, slower but able (in principle) of - ! handling any format. In this case, a block of rows is extracted - ! instead of a single row, for performance reasons, and these - ! rows are copied one by one into laspk, dia, uaspk, through - ! successive calls to ilu_copyin. - ! + ! + ! Otherwise use psb_sp_getblk, slower but able (in principle) of + ! handling any format. In this case, a block of rows is extracted + ! instead of a single row, for performance reasons, and these + ! rows are copied one by one into lval, dia, uval, through + ! successive calls to ilu_copyin. + ! - if ((mod(i,nrb) == 1).or.(nrb == 1)) then - irb = min(m-i+1,nrb) - call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1) - if(info.ne.0) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_getblk' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - ktrw=1 - end if - - do - if (ktrw > trw%infoa(psb_nnz_)) exit - if (trw%ia1(ktrw) > i) exit - k = trw%ia2(ktrw) - if ((k < jd).and.(k >= jmin)) then - l1 = l1 + 1 - laspk(l1) = trw%aspk(ktrw) - lia1(l1) = k - else if (k == jd) then - dia = trw%aspk(ktrw) - else if ((k > jd).and.(k <= jmax)) then - l2 = l2 + 1 - uaspk(l2) = trw%aspk(ktrw) - uia1(l2) = k + if ((mod(i,nrb) == 1).or.(nrb == 1)) then + irb = min(m-i+1,nrb) + call aa%csget(i,i+irb-1,trw,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='csget' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ktrw=1 end if - ktrw = ktrw + 1 - enddo + + nz = trw%get_nzeros() + do + if (ktrw > nz) exit + if (trw%ia(ktrw) > i) exit + k = trw%ja(ktrw) + if ((k < jd).and.(k >= jmin)) then + l1 = l1 + 1 + lval(l1) = trw%val(ktrw) + lja(l1) = k + else if (k == jd) then + dia = trw%val(ktrw) + else if ((k > jd).and.(k <= jmax)) then + l2 = l2 + 1 + uval(l2) = trw%val(ktrw) + uja(l2) = k + end if + ktrw = ktrw + 1 + enddo + + end select + + else + + write(0,*) 'Update not implemented ' + info = 31 + call psb_errpush(info,name,i_err=(/13,0,0,0,0/),a_err=upd) + goto 9999 end if diff --git a/mlprec/mld_silu_bld.f90 b/mlprec/mld_silu_bld.f90 deleted file mode 100644 index cbcfcefe..00000000 --- a/mlprec/mld_silu_bld.f90 +++ /dev/null @@ -1,280 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,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. -!!$ -!!$ -! File: mld_silu_bld.f90 -! -! Subroutine: mld_silu_bld -! Version: real -! -! This routine computes an incomplete LU (ILU) factorization of the diagonal -! blocks of a distributed matrix. This factorization is used to build the -! 'base preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz -! preconditioner) corresponding to a certain level of a multilevel preconditioner. -! -! The following factorizations are available: -! - ILU(k), i.e. ILU factorization with fill-in level k, -! - MILU(k), i.e. modified ILU factorization with fill-in level k, -! - ILU(k,t), i.e. ILU with threshold (i.e. drop tolerance) t and k additional -! entries in each row of the L and U factors with respect to the initial -! sparsity pattern. -! Note that the meaning of k in ILU(k,t) is different from that in ILU(k) and -! MILU(k). -! -! For details on the above factorizations see -! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition, -! SIAM, 2003, Chapter 10. -! -! Note that that this routine handles the ILU(0) factorization separately, -! through mld_ilu0_fact, for performance reasons. -! -! -! Arguments: -! a - type(psb_sspmat_type), input. -! The sparse matrix structure containing the local matrix. -! Note that if p%iprcparm(mld_sub_ovr_) > 0, i.e. the -! 'base' Additive Schwarz preconditioner has overlap greater than -! 0, and p%iprcparm(mld_sub_ren_) = 0, i.e. a reordering of the -! matrix has not been performed (see mld_fact_bld), then a contains -! only the 'original' local part of the distributed matrix, -! i.e. the rows of the matrix held by the calling process according -! to the initial data distribution. -! p - type(mld_sbaseprec_type), input/output. -! The 'base preconditioner' data structure. In input, p%iprcparm -! contains information on the type of factorization to be computed. -! In output, p%av(mld_l_pr_) and p%av(mld_u_pr_) contain the -! incomplete L and U factors (without their diagonals), and p%d -! contains the diagonal of the incomplete U factor. For more -! details on p see its description in mld_prec_type.f90. -! info - integer, output. -! Error code. -! blck - type(psb_sspmat_type), input, optional. -! The sparse matrix structure containing the remote rows of the -! distributed matrix, that have been retrieved by mld_as_bld -! to build an Additive Schwarz base preconditioner with overlap -! greater than 0. If the overlap is 0 or the matrix has been reordered -! (see mld_fact_bld), then blck does not contain any row. -! -subroutine mld_silu_bld(a,p,upd,info,blck) - - use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_silu_bld - - implicit none - -! Arguments - type(psb_sspmat_type), intent(in), target :: a - type(mld_sbaseprec_type), intent(inout) :: p - character, intent(in) :: upd - integer, intent(out) :: info - type(psb_sspmat_type), intent(in), optional :: blck - - ! Local Variables - integer :: i, nztota, err_act, n_row, nrow_a - character :: trans, unitd - integer :: debug_level, debug_unit - integer :: ictxt,np,me - character(len=20) :: name, ch_err - - if(psb_get_errstatus().ne.0) return - info=psb_success_ - name='mld_silu_bld' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = psb_cd_get_context(p%desc_data) - call psb_info(ictxt, me, np) - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),' start' - trans = 'N' - unitd = 'U' - - ! - ! Check the memory available to hold the incomplete L and U factors - ! and allocate it if needed - ! - - if (allocated(p%av)) then - if (size(p%av) < mld_bp_ilu_avsz_) then - do i=1,size(p%av) - call psb_sp_free(p%av(i),info) - if (info /= psb_success_) then - ! Actually, we don't care here about this. Just let it go. - ! return - end if - enddo - deallocate(p%av,stat=info) - endif - end if - if (.not.allocated(p%av)) then - allocate(p%av(mld_max_avsz_),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - endif - - nrow_a = psb_sp_get_nrows(a) - nztota = psb_sp_get_nnzeros(a) - if (present(blck)) then - nztota = nztota + psb_sp_get_nnzeros(blck) - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ': out get_nnzeros',nztota,a%m,a%k,nrow_a - - n_row = p%desc_data%matrix_data(psb_n_row_) - p%av(mld_l_pr_)%m = n_row - p%av(mld_l_pr_)%k = n_row - p%av(mld_u_pr_)%m = n_row - p%av(mld_u_pr_)%k = n_row - call psb_sp_all(n_row,n_row,p%av(mld_l_pr_),nztota,info) - if (info == psb_success_) call psb_sp_all(n_row,n_row,p%av(mld_u_pr_),nztota,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if (allocated(p%d)) then - if (size(p%d) < n_row) then - deallocate(p%d) - endif - endif - if (.not.allocated(p%d)) then - allocate(p%d(n_row),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - endif - - select case(p%iprcparm(mld_sub_solve_)) - - case (mld_ilu_t_) - ! - ! ILU(k,t) - ! - - select case(p%iprcparm(mld_sub_fillin_)) - - case(:-1) - ! Error: fill-in <= -1 - call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,p%iprcparm(mld_sub_fillin_),0,0,0/)) - goto 9999 - - case(0:) - ! Fill-in >= 0 - call mld_ilut_fact(p%iprcparm(mld_sub_fillin_),p%rprcparm(mld_sub_iluthrs_),& - & a, p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck) - end select - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_ilut_fact' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case(mld_ilu_n_,mld_milu_n_) - ! - ! ILU(k) and MILU(k) - ! - select case(p%iprcparm(mld_sub_fillin_)) - case(:-1) - ! Error: fill-in <= -1 - call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,p%iprcparm(mld_sub_fillin_),0,0,0/)) - goto 9999 - case(0) - ! Fill-in 0 - ! Separate implementation of ILU(0) for better performance. - ! There seems to be a problem with the separate implementation of MILU(0), - ! contained into mld_ilu0_fact. This must be investigated. For the time being, - ! resort to the implementation of MILU(k) with k=0. - if (p%iprcparm(mld_sub_solve_) == mld_ilu_n_) then - call mld_ilu0_fact(p%iprcparm(mld_sub_solve_),a,p%av(mld_l_pr_),p%av(mld_u_pr_),& - & p%d,info,blck=blck) - else - call mld_iluk_fact(p%iprcparm(mld_sub_fillin_),p%iprcparm(mld_sub_solve_),& - & a,p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck) - endif - case(1:) - ! Fill-in >= 1 - ! The same routine implements both ILU(k) and MILU(k) - call mld_iluk_fact(p%iprcparm(mld_sub_fillin_),p%iprcparm(mld_sub_solve_),& - & a,p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck) - end select - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='mld_iluk_fact' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case default - ! If we end up here, something was wrong up in the call chain. - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - - end select - - if (psb_sp_getifld(psb_upd_,p%av(mld_u_pr_),info) /= psb_upd_perm_) then - call psb_sp_trim(p%av(mld_u_pr_),info) - endif - - if (psb_sp_getifld(psb_upd_,p%av(mld_l_pr_),info) /= psb_upd_perm_) then - call psb_sp_trim(p%av(mld_l_pr_),info) - endif - - 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.eq.psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine mld_silu_bld - - diff --git a/mlprec/mld_siluk_fact.f90 b/mlprec/mld_siluk_fact.f90 index 37a5b7b7..9b4ca5ac 100644 --- a/mlprec/mld_siluk_fact.f90 +++ b/mlprec/mld_siluk_fact.f90 @@ -99,7 +99,7 @@ subroutine mld_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_siluk_fact + use mld_inner_mod!, mld_protect_name => mld_siluk_fact implicit none @@ -114,6 +114,7 @@ subroutine mld_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) integer :: l1, l2, m, err_act type(psb_sspmat_type), pointer :: blck_ + type(psb_s_csr_sparse_mat) :: ll, uu character(len=20) :: name, ch_err name='mld_siluk_fact' @@ -127,26 +128,32 @@ subroutine mld_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) blck_ => blck else allocate(blck_,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - call psb_sp_all(0,0,blck_,1,info) + if (info == psb_success_) call blck_%csall(0,0,info,1) if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='csall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if - endif + m = a%get_nrows() + blck_%get_nrows() + if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& + & (m > size(d)) ) then + write(0,*) 'Wrong allocation status for L,D,U? ',& + & l%get_nrows(),size(d),u%get_nrows() + info = -1 + return + end if + + call l%mv_to(ll) + call u%mv_to(uu) + ! ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg ! - call mld_siluk_factint(fill_in,ialg,m,a,blck_,& - & d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) + call mld_siluk_factint(fill_in,ialg,a,blck_,& + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='mld_siluk_factint' @@ -157,33 +164,32 @@ subroutine mld_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) ! ! Store information on the L and U sparse matrices ! - l%infoa(1) = l1 - l%fida = 'CSR' - l%descra = 'TLU' - u%infoa(1) = l2 - u%fida = 'CSR' - u%descra = 'TUU' - l%m = m - l%k = m - u%m = m - u%k = m - + call l%mv_from(ll) + call l%set_triangle() + call l%set_unit() + call l%set_lower() + call u%mv_from(uu) + call u%set_triangle() + call u%set_unit() + call u%set_upper() + ! - ! Nullify the pointer / deallocate the memory + ! Nullify pointer / deallocate memory ! if (present(blck)) then blck_ => null() else - call psb_sp_free(blck_,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + call blck_%free() + deallocate(blck_,stat=info) + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if - deallocate(blck_) endif + call psb_erractionrestore(err_act) return @@ -248,43 +254,43 @@ contains ! lia2 - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row ! of the L factor in laspk, according to the CSR storage format. - ! uaspk - real(psb_spk_), dimension(:), input/output. + ! uval - real(psb_spk_), dimension(:), input/output. ! The U factor in the incomplete factorization. ! The entries of U are stored according to the CSR format. - ! uia1 - integer, dimension(:), input/output. + ! uja - integer, dimension(:), input/output. ! The column indices of the nonzero entries of the U factor, ! according to the CSR storage format. - ! uia2 - integer, dimension(:), input/output. + ! uirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the U factor in uaspk, according to the CSR storage format. + ! of the U factor in uval, according to the CSR storage format. ! l1 - integer, output ! The number of nonzero entries in laspk. ! l2 - integer, output - ! The number of nonzero entries in uaspk. + ! The number of nonzero entries in uval. ! info - integer, output. ! Error code. ! - subroutine mld_siluk_factint(fill_in,ialg,m,a,b,& - & d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info) + subroutine mld_siluk_factint(fill_in,ialg,a,b,& + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info) use psb_sparse_mod implicit none ! Arguments - integer, intent(in) :: fill_in, ialg - type(psb_sspmat_type), intent(in) :: a,b - integer, intent(inout) :: m,l1,l2,info - integer, allocatable, intent(inout) :: lia1(:),lia2(:),uia1(:),uia2(:) - real(psb_spk_), allocatable, intent(inout) :: laspk(:),uaspk(:) + integer, intent(in) :: fill_in, ialg + type(psb_sspmat_type),intent(in) :: a,b + integer,intent(inout) :: l1,l2,info + integer, allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) + real(psb_spk_), allocatable, intent(inout) :: lval(:),uval(:) real(psb_spk_), intent(inout) :: d(:) ! Local variables - integer :: ma,mb,i, ktrw,err_act,nidx + integer :: ma,mb,i, ktrw,err_act,nidx, m integer, allocatable :: uplevs(:), rowlevs(:),idxs(:) - real(psb_spk_), allocatable :: row(:) + real(psb_spk_), allocatable :: row(:) type(psb_int_heap) :: heap - type(psb_sspmat_type) :: trw + type(psb_s_coo_sparse_mat) :: trw character(len=20), parameter :: name='mld_siluk_factint' character(len=20) :: ch_err @@ -292,6 +298,7 @@ contains info=psb_success_ call psb_erractionsave(err_act) + select case(ialg) case(mld_ilu_n_,mld_milu_n_) ! Ok @@ -306,16 +313,17 @@ contains goto 9999 end if - ma = a%m - mb = b%m + ma = a%get_nrows() + mb = b%get_nrows() m = ma+mb ! ! Allocate a temporary buffer for the iluk_copyin function ! - call psb_sp_all(0,0,trw,1,info) - if (info == psb_success_) call psb_ensure_size(m+1,lia2,info) - if (info == psb_success_) call psb_ensure_size(m+1,uia2,info) + + call trw%allocate(0,0,1) + if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) + if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ @@ -325,14 +333,14 @@ contains l1=0 l2=0 - lia2(1) = 1 - uia2(1) = 1 + lirp(1) = 1 + uirp(1) = 1 ! ! Allocate memory to hold the entries of a row and the corresponding ! fill levels ! - allocate(uplevs(size(uaspk)),rowlevs(m),row(m),stat=info) + allocate(uplevs(size(uval)),rowlevs(m),row(m),stat=info) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') @@ -375,12 +383,12 @@ contains ! do not have a lowlevs variable. ! if (info == psb_success_) call iluk_fact(fill_in,i,row,rowlevs,heap,& - & d,uia1,uia2,uaspk,uplevs,nidx,idxs,info) + & d,uja,uirp,uval,uplevs,nidx,idxs,info) ! - ! Copy the row into laspk/d(i)/uaspk + ! Copy the row into lval/d(i)/uval ! if (info == psb_success_) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& - & l1,l2,lia1,lia2,laspk,d,uia1,uia2,uaspk,uplevs,info) + & l1,l2,lja,lirp,lval,d,uja,uirp,uval,uplevs,info) if (info /= psb_success_) then info=psb_err_internal_error_ call psb_errpush(info,name,a_err='Copy/factor loop') @@ -397,7 +405,7 @@ contains call psb_errpush(info,name,a_err='Deallocate') goto 9999 end if - if (info == psb_success_) call psb_sp_free(trw,info) + if (info == psb_success_) call trw%free() if (info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_sp_free' @@ -489,7 +497,7 @@ contains ! Arguments type(psb_sspmat_type), intent(in) :: a - type(psb_sspmat_type), intent(inout) :: trw + type(psb_s_coo_sparse_mat), intent(inout) :: trw integer, intent(in) :: i,m,jmin,jmax integer, intent(inout) :: ktrw,info integer, intent(inout) :: rowlevs(:) @@ -497,8 +505,8 @@ contains type(psb_int_heap), intent(inout) :: heap ! Local variables - integer :: k,j,irb,err_act - integer, parameter :: nrb=16 + integer :: k,j,irb,err_act,nz + integer, parameter :: nrb=40 character(len=20), parameter :: name='iluk_copyin' character(len=20) :: ch_err @@ -507,22 +515,22 @@ contains call psb_erractionsave(err_act) call psb_init_heap(heap,info) - if (psb_toupper(a%fida) == 'CSR') then - + select type (aa=> a%a) + type is (psb_s_csr_sparse_mat) ! ! Take a fast shortcut if the matrix is stored in CSR format ! - do j = a%ia2(i), a%ia2(i+1) - 1 - k = a%ia1(j) + do j = aa%irp(i), aa%irp(i+1) - 1 + k = aa%ja(j) if ((jmin<=k).and.(k<=jmax)) then - row(k) = a%aspk(j) + row(k) = aa%val(j) rowlevs(k) = 0 call psb_insert_heap(k,heap,info) end if end do - else + class default ! ! Otherwise use psb_sp_getblk, slower but able (in principle) of @@ -534,7 +542,7 @@ contains if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(m-i+1,nrb) - call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1) + call aa%csget(i,i+irb-1,trw,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_sp_getblk' @@ -543,19 +551,19 @@ contains end if ktrw=1 end if - + nz = trw%get_nzeros() do - if (ktrw > trw%infoa(psb_nnz_)) exit - if (trw%ia1(ktrw) > i) exit - k = trw%ia2(ktrw) + if (ktrw > nz) exit + if (trw%ia(ktrw) > i) exit + k = trw%ja(ktrw) if ((jmin<=k).and.(k<=jmax)) then - row(k) = trw%aspk(ktrw) + row(k) = trw%val(ktrw) rowlevs(k) = 0 call psb_insert_heap(k,heap,info) end if ktrw = ktrw + 1 enddo - end if + end select call psb_erractionrestore(err_act) return @@ -611,17 +619,17 @@ contains ! d - real(psb_spk_), input. ! The inverse of the diagonal entries of the part of the U factor ! above the current row (see iluk_copyout). - ! uia1 - integer, dimension(:), input. + ! uja - integer, dimension(:), input. ! The column indices of the nonzero entries of the part of the U - ! factor above the current row, stored in uaspk row by row (see + ! factor above the current row, stored in uval row by row (see ! iluk_copyout, called by mld_siluk_factint), according to the CSR ! storage format. - ! uia2 - integer, dimension(:), input. + ! uirp - integer, dimension(:), input. ! The indices identifying the first nonzero entry of each row of - ! the U factor above the current row, stored in uaspk row by row + ! the U factor above the current row, stored in uval row by row ! (see iluk_copyout, called by mld_siluk_factint), according to ! the CSR storage format. - ! uaspk - real(psb_spk_), dimension(:), input. + ! uval - real(psb_spk_), dimension(:), input. ! The entries of the U factor above the current row (except the ! diagonal ones), stored according to the CSR format. ! uplevs - integer, dimension(:), input. @@ -638,7 +646,7 @@ contains ! Note: this argument is intent(inout) and not only intent(out) ! to retain its allocation, done by this routine. ! - subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uia1,uia2,uaspk,uplevs,nidx,idxs,info) + subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uja,uirp,uval,uplevs,nidx,idxs,info) use psb_sparse_mod @@ -650,8 +658,8 @@ contains integer, intent(inout) :: nidx,info integer, intent(inout) :: rowlevs(:) integer, allocatable, intent(inout) :: idxs(:) - integer, intent(inout) :: uia1(:),uia2(:),uplevs(:) - real(psb_spk_), intent(inout) :: row(:), uaspk(:),d(:) + integer, intent(inout) :: uja(:),uirp(:),uplevs(:) + real(psb_spk_), intent(inout) :: row(:), uval(:),d(:) ! Local variables integer :: k,j,lrwk,jj,lastk, iret @@ -695,8 +703,8 @@ contains row(k) = row(k) * d(k) ! d(k) == 1/a(k,k) lrwk = rowlevs(k) - do jj=uia2(k),uia2(k+1)-1 - j = uia1(jj) + do jj=uirp(k),uirp(k+1)-1 + j = uja(jj) if (j<=k) then info = -i return @@ -716,7 +724,7 @@ contains ! ! Update row(j) and the corresponding fill level ! - row(j) = row(j) - rwk * uaspk(jj) + row(j) = row(j) - rwk * uval(jj) rowlevs(j) = min(rowlevs(j),lrwk+uplevs(jj)+1) end do @@ -731,19 +739,19 @@ contains ! Note: internal subroutine of mld_siluk_fact ! ! This routine copies a matrix row, computed by iluk_fact by applying an - ! elimination step of the ILU(k) factorization, into the arrays laspk, uaspk, + ! elimination step of the ILU(k) factorization, into the arrays lval, uval, ! d, corresponding to the L factor, the U factor and the diagonal of U, ! respectively. ! ! Note that - ! - the part of the row stored into uaspk is scaled by the corresponding diagonal + ! - the part of the row stored into uval is scaled by the corresponding diagonal ! entry, according to the LDU form of the incomplete factorization; ! - the inverse of the diagonal entries of U is actually stored into d; this is ! then managed in the solve stage associated to the ILU(k)/MILU(k) factorization; ! - if the MILU(k) factorization has been required (ialg == mld_milu_n_), the ! row entries discarded because their fill levels are too high are added to ! the diagonal entry of the row; - ! - the row entries are stored in laspk and uaspk according to the CSR format; + ! - the row entries are stored in lval and uval according to the CSR format; ! - the arrays row and rowlevs are re-initialized for future use in mld_iluk_fact ! (see also iluk_copyin and iluk_fact). ! @@ -781,32 +789,32 @@ contains ! examined during the elimination step carried out by the routine ! iluk_fact. ! l1 - integer, input/output. - ! Pointer to the last occupied entry of laspk. + ! Pointer to the last occupied entry of lval. ! l2 - integer, input/output. - ! Pointer to the last occupied entry of uaspk. - ! lia1 - integer, dimension(:), input/output. + ! Pointer to the last occupied entry of uval. + ! lja - integer, dimension(:), input/output. ! The column indices of the nonzero entries of the L factor, - ! copied in laspk row by row (see mld_siluk_factint), according + ! copied in lval row by row (see mld_siluk_factint), according ! to the CSR storage format. - ! lia2 - integer, dimension(:), input/output. + ! lirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the L factor, copied in laspk row by row (see + ! of the L factor, copied in lval row by row (see ! mld_siluk_factint), according to the CSR storage format. - ! laspk - real(psb_spk_), dimension(:), input/output. + ! lval - real(psb_spk_), dimension(:), input/output. ! The array where the entries of the row corresponding to the ! L factor are copied. ! d - real(psb_spk_), dimension(:), input/output. ! The array where the inverse of the diagonal entry of the ! row is copied (only d(i) is used by the routine). - ! uia1 - integer, dimension(:), input/output. + ! uja - integer, dimension(:), input/output. ! The column indices of the nonzero entries of the U factor - ! copied in uaspk row by row (see mld_siluk_factint), according + ! copied in uval row by row (see mld_siluk_factint), according ! to the CSR storage format. - ! uia2 - integer, dimension(:), input/output. + ! uirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the U factor copied in uaspk row by row (see + ! of the U factor copied in uval row by row (see ! mld_silu_fctint), according to the CSR storage format. - ! uaspk - real(psb_spk_), dimension(:), input/output. + ! uval - real(psb_spk_), dimension(:), input/output. ! The array where the entries of the row corresponding to the ! U factor are copied. ! uplevs - integer, dimension(:), input. @@ -814,18 +822,18 @@ contains ! U factor above the current row. ! subroutine iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& - & l1,l2,lia1,lia2,laspk,d,uia1,uia2,uaspk,uplevs,info) + & l1,l2,lja,lirp,lval,d,uja,uirp,uval,uplevs,info) use psb_sparse_mod implicit none ! Arguments - integer, intent(in) :: fill_in, ialg, i, m, nidx - integer, intent(inout) :: l1, l2, info - integer, intent(inout) :: rowlevs(:), idxs(:) - integer, allocatable, intent(inout) :: uia1(:), uia2(:), lia1(:), lia2(:),uplevs(:) - real(psb_spk_), allocatable, intent(inout) :: uaspk(:), laspk(:) + integer, intent(in) :: fill_in, ialg, i, m, nidx + integer, intent(inout) :: l1, l2, info + integer, intent(inout) :: rowlevs(:), idxs(:) + integer, allocatable, intent(inout) :: uja(:), uirp(:), lja(:), lirp(:),uplevs(:) + real(psb_spk_), allocatable, intent(inout) :: uval(:), lval(:) real(psb_spk_), intent(inout) :: row(:), d(:) ! Local variables @@ -849,21 +857,21 @@ contains ! if (rowlevs(j) <= fill_in) then l1 = l1 + 1 - if (size(laspk) < l1) then + if (size(lval) < l1) then ! ! Figure out a good reallocation size! ! isz = (max((l1/i)*m,int(1.2*l1),l1+100)) - call psb_realloc(isz,laspk,info) - if (info == psb_success_) call psb_realloc(isz,lia1,info) + call psb_realloc(isz,lval,info) + if (info == psb_success_) call psb_realloc(isz,lja,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if end if - lia1(l1) = j - laspk(l1) = row(j) + lja(l1) = j + lval(l1) = row(j) else if (ialg == mld_milu_n_) then ! ! MILU(k): add discarded entries to the diagonal one @@ -891,13 +899,13 @@ contains ! if (rowlevs(j) <= fill_in) then l2 = l2 + 1 - if (size(uaspk) < l2) then + if (size(uval) < l2) then ! ! Figure out a good reallocation size! ! isz = max((l2/i)*m,int(1.2*l2),l2+100) - call psb_realloc(isz,uaspk,info) - if (info == psb_success_) call psb_realloc(isz,uia1,info) + call psb_realloc(isz,uval,info) + if (info == psb_success_) call psb_realloc(isz,uja,info) if (info == psb_success_) call psb_realloc(isz,uplevs,info,pad=(m+1)) if (info /= psb_success_) then info=psb_err_from_subroutine_ @@ -905,8 +913,8 @@ contains goto 9999 end if end if - uia1(l2) = j - uaspk(l2) = row(j) + uja(l2) = j + uval(l2) = row(j) uplevs(l2) = rowlevs(j) else if (ialg == mld_milu_n_) then ! @@ -917,17 +925,17 @@ contains ! ! Re-initialize row(j) and rowlevs(j) ! - row(j) = szero + row(j) = szero rowlevs(j) = -(m+1) end if end do ! ! Store the pointers to the first non occupied entry of in - ! laspk and uaspk + ! lval and uval ! - lia2(i+1) = l1 + 1 - uia2(i+1) = l2 + 1 + lirp(i+1) = l1 + 1 + uirp(i+1) = l2 + 1 ! ! Check the pivot size @@ -951,8 +959,8 @@ contains ! ! Scale the upper part ! - do j=uia2(i), uia2(i+1)-1 - uaspk(j) = d(i)*uaspk(j) + do j=uirp(i), uirp(i+1)-1 + uval(j) = d(i)*uval(j) end do call psb_erractionrestore(err_act) diff --git a/mlprec/mld_silut_fact.f90 b/mlprec/mld_silut_fact.f90 index 9ffb353a..ae0abe8a 100644 --- a/mlprec/mld_silut_fact.f90 +++ b/mlprec/mld_silut_fact.f90 @@ -95,7 +95,7 @@ subroutine mld_silut_fact(fill_in,thres,a,l,u,d,info,blck) use psb_sparse_mod - use mld_inner_mod, mld_protect_name => mld_silut_fact + use mld_inner_mod!, mld_protect_name => mld_silut_fact implicit none @@ -105,13 +105,13 @@ subroutine mld_silut_fact(fill_in,thres,a,l,u,d,info,blck) integer, intent(out) :: info type(psb_sspmat_type),intent(in) :: a type(psb_sspmat_type),intent(inout) :: l,u - real(psb_spk_), intent(inout) :: d(:) type(psb_sspmat_type),intent(in), optional, target :: blck - + real(psb_spk_), intent(inout) :: d(:) ! Local Variables integer :: l1, l2, m, err_act type(psb_sspmat_type), pointer :: blck_ + type(psb_s_csr_sparse_mat) :: ll, uu character(len=20) :: name, ch_err name='mld_silut_fact' @@ -130,26 +130,32 @@ subroutine mld_silut_fact(fill_in,thres,a,l,u,d,info,blck) blck_ => blck else allocate(blck_,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - - call psb_sp_all(0,0,blck_,1,info) + if (info == psb_success_) call blck_%csall(0,0,info,1) if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_all' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + info=psb_err_from_subroutine_ + ch_err='csall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if - endif + m = a%get_nrows() + blck_%get_nrows() + if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.& + & (m > size(d)) ) then + write(0,*) 'Wrong allocation status for L,D,U? ',& + & l%get_nrows(),size(d),u%get_nrows() + info = -1 + return + end if + + call l%mv_to(ll) + call u%mv_to(uu) + ! ! Compute the ILU(k,t) factorization ! - call mld_silut_factint(fill_in,thres,m,a,blck_,& - & d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) + call mld_silut_factint(fill_in,thres,a,blck_,& + & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='mld_silut_factint' @@ -160,31 +166,29 @@ subroutine mld_silut_fact(fill_in,thres,a,l,u,d,info,blck) ! ! Store information on the L and U sparse matrices ! - l%infoa(1) = l1 - l%fida = 'CSR' - l%descra = 'TLU' - u%infoa(1) = l2 - u%fida = 'CSR' - u%descra = 'TUU' - l%m = m - l%k = m - u%m = m - u%k = m - + call l%mv_from(ll) + call l%set_triangle() + call l%set_unit() + call l%set_lower() + call u%mv_from(uu) + call u%set_triangle() + call u%set_unit() + call u%set_upper() + ! - ! Nullify the pointer / deallocate the memory + ! Nullify pointer / deallocate memory ! if (present(blck)) then blck_ => null() else - call psb_sp_free(blck_,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_sp_free' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 + call blck_%free() + deallocate(blck_,stat=info) + if(info.ne.0) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_free' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 end if - deallocate(blck_) endif call psb_erractionrestore(err_act) @@ -241,32 +245,32 @@ contains ! d - real(psb_spk_), dimension(:), output. ! The inverse of the diagonal entries of the U factor in the incomplete ! factorization. - ! laspk - real(psb_spk_), dimension(:), input/output. + ! lval - real(psb_spk_), dimension(:), input/output. ! The L factor in the incomplete factorization. ! lia1 - integer, dimension(:), input/output. ! The column indices of the nonzero entries of the L factor, ! according to the CSR storage format. - ! lia2 - integer, dimension(:), input/output. + ! lirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the L factor in laspk, according to the CSR storage format. - ! uaspk - real(psb_spk_), dimension(:), input/output. + ! of the L factor in lval, according to the CSR storage format. + ! uval - real(psb_spk_), dimension(:), input/output. ! The U factor in the incomplete factorization. ! The entries of U are stored according to the CSR format. - ! uia1 - integer, dimension(:), input/output. + ! uja - integer, dimension(:), input/output. ! The column indices of the nonzero entries of the U factor, ! according to the CSR storage format. - ! uia2 - integer, dimension(:), input/output. + ! uirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the U factor in uaspk, according to the CSR storage format. + ! of the U factor in uval, according to the CSR storage format. ! l1 - integer, output - ! The number of nonzero entries in laspk. + ! The number of nonzero entries in lval. ! l2 - integer, output - ! The number of nonzero entries in uaspk. + ! The number of nonzero entries in uval. ! info - integer, output. ! Error code. ! - subroutine mld_silut_factint(fill_in,thres,m,a,b,& - & d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info) + subroutine mld_silut_factint(fill_in,thres,a,b,& + & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info) use psb_sparse_mod @@ -275,19 +279,19 @@ contains ! Arguments integer, intent(in) :: fill_in real(psb_spk_), intent(in) :: thres - type(psb_sspmat_type), intent(in) :: a,b - integer, intent(inout) :: m,l1,l2,info - integer, allocatable, intent(inout) :: lia1(:),lia2(:),uia1(:),uia2(:) - real(psb_spk_), allocatable, intent(inout) :: laspk(:),uaspk(:) + type(psb_sspmat_type),intent(in) :: a,b + integer,intent(inout) :: l1,l2,info + integer, allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:) + real(psb_spk_), allocatable, intent(inout) :: lval(:),uval(:) real(psb_spk_), intent(inout) :: d(:) ! Local Variables - integer :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb + integer :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb, m real(psb_spk_) :: nrmi integer, allocatable :: idxs(:) real(psb_spk_), allocatable :: row(:) type(psb_int_heap) :: heap - type(psb_sspmat_type) :: trw + type(psb_s_coo_sparse_mat) :: trw character(len=20), parameter :: name='mld_silut_factint' character(len=20) :: ch_err @@ -296,16 +300,16 @@ contains call psb_erractionsave(err_act) - ma = a%m - mb = b%m + ma = a%get_nrows() + mb = b%get_nrows() m = ma+mb ! ! Allocate a temporary buffer for the ilut_copyin function ! - call psb_sp_all(0,0,trw,1,info) - if (info == psb_success_) call psb_ensure_size(m+1,lia2,info) - if (info == psb_success_) call psb_ensure_size(m+1,uia2,info) + call trw%allocate(0,0,1) + if (info == psb_success_) call psb_ensure_size(m+1,lirp,info) + if (info == psb_success_) call psb_ensure_size(m+1,uirp,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ @@ -315,8 +319,8 @@ contains l1=0 l2=0 - lia2(1) = 1 - uia2(1) = 1 + lirp(1) = 1 + uirp(1) = 1 ! ! Allocate memory to hold the entries of a row @@ -354,12 +358,12 @@ contains ! Do an elimination step on current row ! if (info == psb_success_) call ilut_fact(thres,i,nrmi,row,heap,& - & d,uia1,uia2,uaspk,nidx,idxs,info) + & d,uja,uirp,uval,nidx,idxs,info) ! - ! Copy the row into laspk/d(i)/uaspk + ! Copy the row into lval/d(i)/uval ! if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row,nidx,idxs,& - & l1,l2,lia1,lia2,laspk,d,uia1,uia2,uaspk,info) + & l1,l2,lja,lirp,lval,d,uja,uirp,uval,info) if (info /= psb_success_) then info=psb_err_internal_error_ @@ -378,7 +382,7 @@ contains call psb_errpush(info,name,a_err='Deallocate') goto 9999 end if - if (info == psb_success_) call psb_sp_free(trw,info) + if (info == psb_success_) call trw%free() if (info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_sp_free' @@ -482,17 +486,17 @@ contains subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,nrmi,row,heap,ktrw,trw,info) use psb_sparse_mod implicit none - type(psb_sspmat_type), intent(in) :: a - type(psb_sspmat_type), intent(inout) :: trw - integer, intent(in) :: i, m,jmin,jmax,jd - integer, intent(inout) :: ktrw,nlw,nup,jmaxup,info - real(psb_spk_), intent(inout) :: nrmi,row(:) - type(psb_int_heap), intent(inout) :: heap + type(psb_sspmat_type), intent(in) :: a + type(psb_s_coo_sparse_mat), intent(inout) :: trw + integer, intent(in) :: i, m,jmin,jmax,jd + integer, intent(inout) :: ktrw,nlw,nup,jmaxup,info + real(psb_spk_), intent(inout) :: nrmi,row(:) + type(psb_int_heap), intent(inout) :: heap integer :: k,j,irb,kin,nz - integer, parameter :: nrb=16 - real(psb_spk_) :: dmaxup - real(psb_spk_), external :: snrm2 + integer, parameter :: nrb=40 + real(psb_spk_) :: dmaxup + real(psb_spk_), external :: dnrm2 character(len=20), parameter :: name='mld_silut_factint' if (psb_get_errstatus() /= 0) return @@ -518,23 +522,19 @@ contains jmaxup = 0 dmaxup = szero nrmi = szero - - if (psb_toupper(a%fida) == 'CSR') then - + + select type (aa=> a%a) + type is (psb_s_csr_sparse_mat) ! ! Take a fast shortcut if the matrix is stored in CSR format - ! - - do j = a%ia2(i), a%ia2(i+1) - 1 - k = a%ia1(j) + ! + + do j = aa%irp(i), aa%irp(i+1) - 1 + k = aa%ja(j) if ((jmin<=k).and.(k<=jmax)) then - row(k) = a%aspk(j) + row(k) = aa%val(j) call psb_insert_heap(k,heap,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_insert_heap') - goto 9999 - end if + if (info /= psb_success_) exit end if if (kjd) then @@ -545,9 +545,17 @@ contains end if end if end do - nz = a%ia2(i+1) - a%ia2(i) - nrmi = snrm2(nz,a%aspk(a%ia2(i)),ione) - else + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_insert_heap') + goto 9999 + end if + + nz = aa%irp(i+1) - aa%irp(i) + nrmi = dnrm2(nz,aa%val(aa%irp(i)),ione) + + + class default ! ! Otherwise use psb_sp_getblk, slower but able (in principle) of @@ -559,7 +567,7 @@ contains if ((mod(i,nrb) == 1).or.(nrb == 1)) then irb = min(m-i+1,nrb) - call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1) + call aa%csget(i,i+irb-1,trw,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_sp_getblk') @@ -569,18 +577,16 @@ contains end if kin = ktrw + nz = trw%get_nzeros() do - if (ktrw > trw%infoa(psb_nnz_)) exit - if (trw%ia1(ktrw) > i) exit - k = trw%ia2(ktrw) + if (ktrw > nz) exit + if (trw%ia(ktrw) > i) exit + k = trw%ja(ktrw) if ((jmin<=k).and.(k<=jmax)) then - row(k) = trw%aspk(ktrw) + row(k) = trw%val(ktrw) call psb_insert_heap(k,heap,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_insert_heap') - goto 9999 - end if + if (info /= psb_success_) exit + end if if (kjd) then @@ -593,8 +599,9 @@ contains ktrw = ktrw + 1 enddo nz = ktrw - kin - nrmi = snrm2(nz,trw%aspk(kin),ione) - end if + nrmi = dnrm2(nz,trw%val(kin),ione) + end select + call psb_erractionrestore(err_act) return @@ -644,17 +651,17 @@ contains ! d - real(psb_spk_), input. ! The inverse of the diagonal entries of the part of the U factor ! above the current row (see ilut_copyout). - ! uia1 - integer, dimension(:), input. + ! uja - integer, dimension(:), input. ! The column indices of the nonzero entries of the part of the U - ! factor above the current row, stored in uaspk row by row (see + ! factor above the current row, stored in uval row by row (see ! ilut_copyout, called by mld_silut_factint), according to the CSR ! storage format. - ! uia2 - integer, dimension(:), input. + ! uirp - integer, dimension(:), input. ! The indices identifying the first nonzero entry of each row of - ! the U factor above the current row, stored in uaspk row by row + ! the U factor above the current row, stored in uval row by row ! (see ilut_copyout, called by mld_silut_factint), according to ! the CSR storage format. - ! uaspk - real(psb_spk_), dimension(:), input. + ! uval - real(psb_spk_), dimension(:), input. ! The entries of the U factor above the current row (except the ! diagonal ones), stored according to the CSR format. ! nidx - integer, output. @@ -668,7 +675,7 @@ contains ! Note: this argument is intent(inout) and not only intent(out) ! to retain its allocation, done by this routine. ! - subroutine ilut_fact(thres,i,nrmi,row,heap,d,uia1,uia2,uaspk,nidx,idxs,info) + subroutine ilut_fact(thres,i,nrmi,row,heap,d,uja,uirp,uval,nidx,idxs,info) use psb_sparse_mod @@ -680,8 +687,8 @@ contains integer, intent(inout) :: nidx,info real(psb_spk_), intent(in) :: thres,nrmi integer, allocatable, intent(inout) :: idxs(:) - integer, intent(inout) :: uia1(:),uia2(:) - real(psb_spk_), intent(inout) :: row(:), uaspk(:),d(:) + integer, intent(inout) :: uja(:),uirp(:) + real(psb_spk_), intent(inout) :: row(:), uval(:),d(:) ! Local Variables integer :: k,j,jj,lastk,iret @@ -725,8 +732,8 @@ contains ! Note: since U is scaled while copying it out (see ilut_copyout), ! we can use rwk in the update below. ! - do jj=uia2(k),uia2(k+1)-1 - j = uia1(jj) + do jj=uirp(k),uirp(k+1)-1 + j = uja(jj) if (j<=k) then info = -i return @@ -735,7 +742,7 @@ contains ! Update row(j) and, if it is not to be discarded, insert ! its index into the heap for further processing. ! - row(j) = row(j) - rwk * uaspk(jj) + row(j) = row(j) - rwk * uval(jj) if (abs(row(j)) < thres*nrmi) then ! ! Drop the entry. @@ -770,8 +777,8 @@ contains ! Note: internal subroutine of mld_silut_fact ! ! This routine copies a matrix row, computed by ilut_fact by applying an - ! elimination step of the ILU(k,t) factorization, into the arrays laspk, - ! uaspk, d, corresponding to the L factor, the U factor and the diagonal + ! elimination step of the ILU(k,t) factorization, into the arrays lval, + ! uval, d, corresponding to the L factor, the U factor and the diagonal ! of U, respectively. ! ! Note that @@ -780,11 +787,11 @@ contains ! the 'lower part' of the row, and the nup+k ones in the 'upper part'; ! - the entry in the upper part of the row which has maximum absolute value ! in the original matrix is included in the above nup+k entries anyway; - ! - the part of the row stored into uaspk is scaled by the corresponding + ! - the part of the row stored into uval is scaled by the corresponding ! diagonal entry, according to the LDU form of the incomplete factorization; ! - the inverse of the diagonal entries of U is actually stored into d; this ! is then managed in the solve stage associated to the ILU(k,t) factorization; - ! - the row entries are stored in laspk and uaspk according to the CSR format; + ! - the row entries are stored in lval and uval according to the CSR format; ! - the array row is re-initialized for future use in mld_ilut_fact(see also ! ilut_copyin and ilut_fact). ! @@ -824,37 +831,37 @@ contains ! examined during the elimination step carried out by the routine ! ilut_fact. ! l1 - integer, input/output. - ! Pointer to the last occupied entry of laspk. + ! Pointer to the last occupied entry of lval. ! l2 - integer, input/output. - ! Pointer to the last occupied entry of uaspk. - ! lia1 - integer, dimension(:), input/output. + ! Pointer to the last occupied entry of uval. + ! lja - integer, dimension(:), input/output. ! The column indices of the nonzero entries of the L factor, - ! copied in laspk row by row (see mld_silut_factint), according + ! copied in lval row by row (see mld_silut_factint), according ! to the CSR storage format. - ! lia2 - integer, dimension(:), input/output. + ! lirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the L factor, copied in laspk row by row (see + ! of the L factor, copied in lval row by row (see ! mld_silut_factint), according to the CSR storage format. - ! laspk - real(psb_spk_), dimension(:), input/output. + ! lval - real(psb_spk_), dimension(:), input/output. ! The array where the entries of the row corresponding to the ! L factor are copied. ! d - real(psb_spk_), dimension(:), input/output. ! The array where the inverse of the diagonal entry of the ! row is copied (only d(i) is used by the routine). - ! uia1 - integer, dimension(:), input/output. + ! uja - integer, dimension(:), input/output. ! The column indices of the nonzero entries of the U factor - ! copied in uaspk row by row (see mld_silut_factint), according + ! copied in uval row by row (see mld_silut_factint), according ! to the CSR storage format. - ! uia2 - integer, dimension(:), input/output. + ! uirp - integer, dimension(:), input/output. ! The indices identifying the first nonzero entry of each row - ! of the U factor copied in uaspk row by row (see + ! of the U factor copied in uval row by row (see ! mld_silu_fctint), according to the CSR storage format. - ! uaspk - real(psb_spk_), dimension(:), input/output. + ! uval - real(psb_spk_), dimension(:), input/output. ! The array where the entries of the row corresponding to the ! U factor are copied. ! subroutine ilut_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row, & - & nidx,idxs,l1,l2,lia1,lia2,laspk,d,uia1,uia2,uaspk,info) + & nidx,idxs,l1,l2,lja,lirp,lval,d,uja,uirp,uval,info) use psb_sparse_mod @@ -864,18 +871,18 @@ contains integer, intent(in) :: fill_in,i,m,nidx,nlw,nup,jmaxup integer, intent(in) :: idxs(:) integer, intent(inout) :: l1,l2, info - integer, allocatable, intent(inout) :: uia1(:),uia2(:), lia1(:),lia2(:) + integer, allocatable, intent(inout) :: uja(:),uirp(:), lja(:),lirp(:) real(psb_spk_), intent(in) :: thres,nrmi - real(psb_spk_),allocatable, intent(inout) :: uaspk(:), laspk(:) + real(psb_spk_),allocatable, intent(inout) :: uval(:), lval(:) real(psb_spk_), intent(inout) :: row(:), d(:) ! Local variables - real(psb_spk_),allocatable :: xw(:) + real(psb_spk_),allocatable :: xw(:) integer, allocatable :: xwid(:), indx(:) - real(psb_spk_) :: witem + real(psb_spk_) :: witem integer :: widx integer :: k,isz,err_act,int_err(5),idxp, nz - type(psb_real_idx_heap) :: heap + type(psb_real_idx_heap) :: heap character(len=20), parameter :: name='ilut_copyout' character(len=20) :: ch_err logical :: fndmaxup @@ -965,21 +972,21 @@ contains ! do k=1,nz l1 = l1 + 1 - if (size(laspk) < l1) then + if (size(lval) < l1) then ! ! Figure out a good reallocation size! ! isz = (max((l1/i)*m,int(1.2*l1),l1+100)) - call psb_realloc(isz,laspk,info) - if (info == psb_success_) call psb_realloc(isz,lia1,info) + call psb_realloc(isz,lval,info) + if (info == psb_success_) call psb_realloc(isz,lja,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if end if - lia1(l1) = xwid(k) - laspk(l1) = xw(indx(k)) + lja(l1) = xwid(k) + lval(l1) = xw(indx(k)) end do ! @@ -1111,21 +1118,21 @@ contains ! do k=1,nz l2 = l2 + 1 - if (size(uaspk) < l2) then + if (size(uval) < l2) then ! ! Figure out a good reallocation size! ! isz = max((l2/i)*m,int(1.2*l2),l2+100) - call psb_realloc(isz,uaspk,info) - if (info == psb_success_) call psb_realloc(isz,uia1,info) + call psb_realloc(isz,uval,info) + if (info == psb_success_) call psb_realloc(isz,uja,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='Allocate') goto 9999 end if end if - uia1(l2) = xwid(k) - uaspk(l2) = d(i)*xw(indx(k)) + uja(l2) = xwid(k) + uval(l2) = d(i)*xw(indx(k)) end do ! @@ -1137,10 +1144,10 @@ contains ! ! Store the pointers to the first non occupied entry of in - ! laspk and uaspk + ! lval and uval ! - lia2(i+1) = l1 + 1 - uia2(i+1) = l2 + 1 + lirp(i+1) = l1 + 1 + uirp(i+1) = l2 + 1 call psb_erractionrestore(err_act) return