mld2p4:
Makefile mld_base_prec_type.f90 mld_d_prec_type.f03 mld_daggrmat_smth_asb.F90 mld_das_aply.f90 mld_das_bld.f90 mld_dbaseprec_aply.f90 mld_dbaseprec_bld.f90 mld_dilu_bld.f90 mld_move_alloc_mod.f90 mld_s_as_smoother.f03 mld_s_diag_solver.f03 mld_s_ilu_solver.f03 mld_s_prec_type.f03 mld_s_prec_type.f90 mld_saggrmap_bld.f90 mld_saggrmat_nosmth_asb.F90 mld_saggrmat_smth_asb.F90 mld_sas_aply.f90 mld_sas_bld.f90 mld_sbaseprec_aply.f90 mld_sbaseprec_bld.f90 mld_scoarse_bld.f90 mld_silu0_fact.f90 mld_silu_bld.f90 mld_siluk_fact.f90 mld_silut_fact.f90 Start of SINGLE PRECISION implementation.stopcriterion
Salvatore Filippone
14 years ago
parent
24ddb9bbdc
commit
df14643465
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue