fdurastante/amg4psblas
1
0
Fork 0
mirror of https://github.com/sfilippone/amg4psblas.git synced 2026-10-07 07:04:59 +00:00
Code Issues Packages Projects Releases Wiki Activity

mld2p4:

Browse Source 
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.
This commit is contained in:
Salvatore Filippone
2010-11-02 16:06:32 +00:00
parent 24ddb9bbdc
commit df14643465
27 changed files with 4153 additions and 4340 deletions
Download Patch File Download Diff File Expand all files Collapse all files
mlprec/Makefile
+9 -10
View File
@@ -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)
#
mlprec/mld_base_prec_type.f90
+2 -1
View File
@@ -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
mlprec/mld_d_prec_type.f03
+1 -1
View File
@@ -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
mlprec/mld_daggrmat_smth_asb.F90
+2 -40
View File
@@ -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
mlprec/mld_das_aply.f90
-411
View File
@@ -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
mlprec/mld_das_bld.f90
-270
View File
@@ -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
mlprec/mld_dbaseprec_aply.f90
-189
View File
@@ -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
mlprec/mld_dbaseprec_bld.f90
-215
View File
@@ -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
mlprec/mld_dilu_bld.f90
-287
View File
@@ -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
mlprec/mld_move_alloc_mod.f90
+6 -6
View File
@@ -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
mlprec/mld_s_as_smoother.f03
+874
View File
@@ -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
mlprec/mld_s_diag_solver.f03
+466
View File
@@ -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
mlprec/mld_s_ilu_solver.f03
+606
View File
@@ -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
mlprec/mld_s_prec_type.f03
+1406
View File
File diff suppressed because it is too large Load Diff
mlprec/mld_s_prec_type.f90
-702
View File
@@ -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
mlprec/mld_saggrmap_bld.f90
+18 -18
View File
@@ -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')
mlprec/mld_saggrmat_nosmth_asb.F90
+50 -72
View File
@@ -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
mlprec/mld_saggrmat_smth_asb.F90
+164 -228
View File
@@ -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
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
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='this section only CSR')
goto 9999
endif
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_)
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
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)
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)
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
call bcoo%free()
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_)
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
mlprec/mld_sas_aply.f90
-407
View File
@@ -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
mlprec/mld_sas_bld.f90
-287
View File
@@ -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
mlprec/mld_sbaseprec_aply.f90
-189
View File
@@ -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
mlprec/mld_sbaseprec_bld.f90
-215
View File
@@ -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
mlprec/mld_scoarse_bld.f90
+6 -6
View File
@@ -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
mlprec/mld_silu0_fact.f90
+258 -236
View File
@@ -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
lia2(i+1) = l1 + 1
uia2(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
if (i <= ma) then
!
j = uia1(jj)
! Copy the i-th local row of the matrix, stored in a,
! into lval/d(i)/uval
!
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
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
else if (j == i) then
lirp(i+1) = l1 + 1
uirp(i+1) = l2 + 1
dia = d(i)
do kk = lirp(i), lirp(i+1) - 1
!
! Compute entry l(i,k) (lower factor L) of the incomplete
! factorization
!
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
! 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).
!
! search u(i,*) (i-th row of U) for a matching index j
!
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 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).
!
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
if (ialg == mld_milu_n_) then
dia = dia - temp*uval(jj)
end if
enddo updateloop
enddo
!
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
! 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
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
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 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 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
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
!
! 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.
!
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
end if
ktrw = ktrw + 1
enddo
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
mlprec/mld_silu_bld.f90
-280
View File
@@ -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
mlprec/mld_siluk_fact.f90
+132 -124
View File
@@ -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)
mlprec/mld_silut_fact.f90
+153 -146
View File
@@ -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 (k<jd) nlw = nlw + 1
if (k>jd) 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 (k<jd) nlw = nlw + 1
if (k>jd) 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