fdurastante
/
amg4psblas
mirror of https://github.com/sfilippone/amg4psblas.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

mld2p4:

Browse Source 
Makefile
 mld_base_prec_type.f90
 mld_d_prec_type.f03
 mld_daggrmat_smth_asb.F90
 mld_das_aply.f90
 mld_das_bld.f90
 mld_dbaseprec_aply.f90
 mld_dbaseprec_bld.f90
 mld_dilu_bld.f90
 mld_move_alloc_mod.f90
 mld_s_as_smoother.f03
 mld_s_diag_solver.f03
 mld_s_ilu_solver.f03
 mld_s_prec_type.f03
 mld_s_prec_type.f90
 mld_saggrmap_bld.f90
 mld_saggrmat_nosmth_asb.F90
 mld_saggrmat_smth_asb.F90
 mld_sas_aply.f90
 mld_sas_bld.f90
 mld_sbaseprec_aply.f90
 mld_sbaseprec_bld.f90
 mld_scoarse_bld.f90
 mld_silu0_fact.f90
 mld_silu_bld.f90
 mld_siluk_fact.f90
 mld_silut_fact.f90

Start of SINGLE PRECISION implementation.
stopcriterion
Salvatore Filippone 14 years ago
parent 24ddb9bbdc
commit df14643465
27 changed files with 4155 additions and 4342 deletions
Show Stats Download Patch File Download Diff File

19
mlprec/Makefile
Unescape Escape View File

@ -9,17 +9,16 @@ FINCLUDES=$(FMFLAG). $(FMFLAG)$(LIBDIR) $(FMFLAG)$(PSBLIBDIR)
MODOBJS=mld_base_prec_type.o \ MODOBJS=mld_base_prec_type.o \
mld_s_prec_type.o mld_d_prec_type.o mld_c_prec_type.o mld_z_prec_type.o \ mld_s_prec_type.o mld_d_prec_type.o mld_c_prec_type.o mld_z_prec_type.o \
mld_prec_type.o mld_prec_mod.o mld_inner_mod.o mld_move_alloc_mod.o\ mld_prec_type.o mld_prec_mod.o mld_inner_mod.o mld_move_alloc_mod.o\
mld_d_ilu_solver.o mld_d_diag_solver.o mld_d_jac_smoother.o mld_d_as_smoother.o mld_d_ilu_solver.o mld_d_diag_solver.o mld_d_jac_smoother.o mld_d_as_smoother.o \
MPFOBJS=mld_daggrmat_nosmth_asb.o mld_daggrmat_smth_asb.o mld_daggrmat_minnrg_asb.o mld_s_ilu_solver.o mld_s_diag_solver.o mld_s_as_smoother.o
MPFOBJS=mld_daggrmat_nosmth_asb.o mld_daggrmat_smth_asb.o mld_daggrmat_minnrg_asb.o \
mld_saggrmat_nosmth_asb.o mld_saggrmat_smth_asb.o
MPCOBJS=mld_sslud_interface.o mld_dslud_interface.o mld_cslud_interface.o mld_zslud_interface.o MPCOBJS=mld_sslud_interface.o mld_dslud_interface.o mld_cslud_interface.o mld_zslud_interface.o
INNEROBJS= mld_dcoarse_bld.o \ INNEROBJS= mld_dcoarse_bld.o mld_dmlprec_bld.o mld_dslu_bld.o mld_dumf_bld.o \
mld_dmlprec_bld.o\ mld_dilu0_fact.o mld_diluk_fact.o mld_dilut_fact.o mld_daggrmap_bld.o \
mld_dslu_bld.o mld_dumf_bld.o \ mld_dmlprec_aply.o mld_dslud_bld.o mld_daggrmat_asb.o \
mld_dilu0_fact.o \ mld_scoarse_bld.o mld_saggrmap_bld.o \
mld_diluk_fact.o mld_dilut_fact.o \ mld_silu0_fact.o mld_siluk_fact.o mld_silut_fact.o \
mld_daggrmap_bld.o \
mld_dmlprec_aply.o mld_dslud_bld.o\
mld_daggrmat_asb.o \
$(MPFOBJS) $(MPFOBJS)
# #

3
mlprec/mld_base_prec_type.f90
Unescape Escape View File

@ -74,7 +74,8 @@ module mld_base_prec_type
& psb_sizeof_int, psb_sizeof_long_int, psb_sizeof_sp, psb_sizeof_dp, psb_sizeof,& & psb_sizeof_int, psb_sizeof_long_int, psb_sizeof_sp, psb_sizeof_dp, psb_sizeof,&
& psb_cd_get_context, psb_info & psb_cd_get_context, psb_info
use psb_prec_mod, only: psb_sprec_type, psb_dprec_type,& use psb_prec_mod, only: psb_sprec_type, psb_dprec_type,&
& psb_cprec_type, psb_zprec_type, psb_d_base_prec_type & psb_cprec_type, psb_zprec_type,&
& psb_d_base_prec_type, psb_s_base_prec_type
type mld_aux_onelev_map_type type mld_aux_onelev_map_type

2
mlprec/mld_d_prec_type.f03
Unescape Escape View File

@ -4,7 +4,7 @@
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package !!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) !!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$ !!$
!!$ (C) Copyright 2008,2009,2010, 2010 !!$ (C) Copyright 2008,2009,2010
!!$ !!$
!!$ Salvatore Filippone University of Rome Tor Vergata !!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse !!$ Alfredo Buttari CNRS-IRIT, Toulouse

42
mlprec/mld_daggrmat_smth_asb.F90
Unescape Escape View File

@ -299,10 +299,10 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
tmp = dzero tmp = dzero
do j=acsr3%irp(i),acsr3%irp(i+1)-1 do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) <= nrw) then if (acsr3%ja(j) <= nrw) then
tmp = tmp + dabs(acsr3%val(j)) tmp = tmp + abs(acsr3%val(j))
endif endif
if (acsr3%ja(j) == i ) then if (acsr3%ja(j) == i ) then
dg = dabs(acsr3%val(j)) dg = abs(acsr3%val(j))
end if end if
end do end do
anorm = max(anorm,tmp/dg) anorm = max(anorm,tmp/dg)
@ -649,44 +649,6 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if(info /= psb_success_) goto 9999 if(info /= psb_success_) goto 9999
!!$
!!$ nzbr(:) = 0
!!$ nzbr(me+1) = b%get_nzeros()
!!$ call psb_sum(ictxt,nzbr(1:np))
!!$ nzac = sum(nzbr)
!!$
!!$ call b%mv_to(bcoo)
!!$ call psb_sum(ictxt,nzbr(1:np))
!!$ nzac = sum(nzbr)
!!$ if (info == psb_success_) call cootmp%allocate(ntaggr,ntaggr,nzac)
!!$ if (info /= psb_success_) goto 9999
!!$
!!$ do ip=1,np
!!$ idisp(ip) = sum(nzbr(1:ip-1))
!!$ enddo
!!$ ndx = nzbr(me+1)
!!$
!!$ call mpi_allgatherv(bcoo%val,ndx,mpi_double_precision,&
!!$ & cootmp%val,nzbr,idisp,&
!!$ & mpi_double_precision,icomm,info)
!!$ if (info == psb_success_) call mpi_allgatherv(bcoo%ia,ndx,mpi_integer,&
!!$ & cootmp%ia,nzbr,idisp,&
!!$ & mpi_integer,icomm,info)
!!$
!!$ if (info == psb_success_) call mpi_allgatherv(bcoo%ja,ndx,mpi_integer,&
!!$ & cootmp%ja,nzbr,idisp,&
!!$ & mpi_integer,icomm,info)
!!$
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
!!$ goto 9999
!!$ end if
!!$ call bcoo%free()
!!$ call cootmp%set_nzeros(nzac)
!!$ call cootmp%set_dupl(psb_dupl_add_)
!!$ call p%ac%mv_from(cootmp)
!!$ if(info /= psb_success_) goto 9999
deallocate(nzbr,idisp,stat=info) deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then

411
mlprec/mld_das_aply.f90
Unescape Escape View File

@ -1,411 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_das_aply.f90
!
! Subroutine: mld_das_aply
! Version: real
!
! This routine applies the Additive Schwarz preconditioner by computing
!
! Y = beta*Y + alpha*op(K^(-1))*X,
! where
! - K is the base preconditioner, stored in prec,
! - op(K^(-1)) is K^(-1) or its transpose, according to the value of trans,
! - X and Y are vectors,
! - alpha and beta are scalars.
!
!
! Arguments:
! alpha - real(psb_dpk_), input.
! The scalar alpha.
! prec - type(mld_dbaseprec_type), input.
! The base preconditioner data structure containing the local part
! of the preconditioner K.
! x - real(psb_dpk_), dimension(:), input.
! The local part of the vector X.
! beta - real(psb_dpk_), input.
! The scalar beta.
! y - real(psb_dpk_), dimension(:), input/output.
! The local part of the vector Y.
! desc_data - type(psb_desc_type), input.
! The communication descriptor associated to the matrix to be
! preconditioned.
! trans - character, optional.
! If trans='N','n' then op(K^(-1)) = K^(-1);
! if trans='T','t' then op(K^(-1)) = K^(-T) (transpose of K^(-1)).
! work - real(psb_dpk_), dimension (:), optional, target.
! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data).
! info - integer, output.
! Error code.
!
subroutine mld_das_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_das_aply
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_dbaseprec_type), intent(in) :: prec
real(psb_dpk_),intent(in) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1) :: trans
real(psb_dpk_),target :: work(:)
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col, int_err(5), nrow_d
real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,isz, err_act
character(len=20) :: name, ch_err
character :: trans_
name='mld_das_aply'
info = psb_success_
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc_data)
call psb_info(ictxt, me, np)
trans_ = psb_toupper(trans)
select case(prec%iprcparm(mld_smoother_type_))
case(mld_bjac_)
call mld_sub_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_sub_aply'
goto 9999
end if
case(mld_as_)
!
! Additive Schwarz preconditioner
!
if ((prec%iprcparm(mld_sub_ovr_) == 0).or.(np==1)) then
!
! Shortcut: this fixes performance for RAS(0) == BJA
!
call mld_sub_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_sub_aply'
goto 9999
end if
else
!
! Overlap > 0
!
n_row = psb_cd_get_local_rows(prec%desc_data)
n_col = psb_cd_get_local_cols(prec%desc_data)
nrow_d = psb_cd_get_local_rows(desc_data)
isz=max(n_row,N_COL)
if ((6*isz) <= size(work)) then
ww => work(1:isz)
tx => work(isz+1:2*isz)
ty => work(2*isz+1:3*isz)
aux => work(3*isz+1:)
else if ((4*isz) <= size(work)) then
aux => work(1:)
allocate(ww(isz),tx(isz),ty(isz),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),&
& a_err='real(psb_dpk_)')
goto 9999
end if
else if ((3*isz) <= size(work)) then
ww => work(1:isz)
tx => work(isz+1:2*isz)
ty => work(2*isz+1:3*isz)
allocate(aux(4*isz),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),&
& a_err='real(psb_dpk_)')
goto 9999
end if
else
allocate(ww(isz),tx(isz),ty(isz),&
&aux(4*isz),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),&
& a_err='real(psb_dpk_)')
goto 9999
end if
endif
tx(1:nrow_d) = x(1:nrow_d)
tx(nrow_d+1:isz) = dzero
select case(trans_)
case('N')
!
! Get the overlap entries of tx (tx == x)
!
if (prec%iprcparm(mld_sub_restr_) == psb_halo_) then
call psb_halo(tx,prec%desc_data,info,work=aux,data=psb_comm_ext_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_halo'
goto 9999
end if
else if (prec%iprcparm(mld_sub_restr_) /= psb_none_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_')
goto 9999
end if
!
! If required, reorder tx according to the row/column permutation of the
! local extended matrix, stored into the permutation vector prec%perm
!
if (prec%iprcparm(mld_sub_ren_)>0) then
!!$ call psb_gelp('n',prec%perm,tx,info)
info = 1
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_gelp'
goto 9999
end if
endif
!
! Apply to tx the block-Jacobi preconditioner/solver (multiple sweeps of the
! block-Jacobi solver can be applied at the coarsest level of a multilevel
! preconditioner). The resulting vector is ty.
!
call mld_sub_aply(done,prec,tx,dzero,ty,prec%desc_data,trans_,aux,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_bjac_aply'
goto 9999
end if
!
! Apply to ty the inverse permutation of prec%perm
!
if (prec%iprcparm(mld_sub_ren_)>0) then
!!$ call psb_gelp('n',prec%invperm,ty,info)
info = 1
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_gelp'
goto 9999
end if
endif
select case (prec%iprcparm(mld_sub_prol_))
case(psb_none_)
!
! Would work anyway, but since it is supposed to do nothing ...
! call psb_ovrl(ty,prec%desc_data,info,&
! & update=prec%iprcparm(mld_sub_prol_),work=aux)
case(psb_sum_,psb_avg_)
!
! Update the overlap of ty
!
call psb_ovrl(ty,prec%desc_data,info,&
& update=prec%iprcparm(mld_sub_prol_),work=aux)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_ovrl'
goto 9999
end if
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_')
goto 9999
end select
case('T','C')
!
! With transpose, we have to do it here
!
select case (prec%iprcparm(mld_sub_prol_))
case(psb_none_)
!
! Do nothing
case(psb_sum_)
!
! The transpose of sum is halo
!
call psb_halo(tx,prec%desc_data,info,work=aux,data=psb_comm_ext_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_halo'
goto 9999
end if
case(psb_avg_)
!
! Tricky one: first we have to scale the overlap entries,
! which we can do by assignind mode=0, i.e. no communication
! (hence only scaling), then we do the halo
!
call psb_ovrl(tx,prec%desc_data,info,&
& update=psb_avg_,work=aux,mode=0)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_ovrl'
goto 9999
end if
call psb_halo(tx,prec%desc_data,info,work=aux,data=psb_comm_ext_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_halo'
goto 9999
end if
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_')
goto 9999
end select
!
! If required, reorder tx according to the row/column permutation of the
! local extended matrix, stored into the permutation vector prec%perm
!
if (prec%iprcparm(mld_sub_ren_)>0) then
!!$ call psb_gelp('n',prec%perm,tx,info)
info = 1
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_gelp'
goto 9999
end if
endif
!
! Apply to tx the block-Jacobi preconditioner/solver (multiple sweeps of the
! block-Jacobi solver can be applied at the coarsest level of a multilevel
! preconditioner). The resulting vector is ty.
!
call mld_sub_aply(done,prec,tx,dzero,ty,prec%desc_data,trans_,aux,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_bjac_aply'
goto 9999
end if
!
! Apply to ty the inverse permutation of prec%perm
!
if (prec%iprcparm(mld_sub_ren_)>0) then
!!$ call psb_gelp('n',prec%invperm,ty,info)
info = 1
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_gelp'
goto 9999
end if
endif
!
! With transpose, we have to do it here
!
if (prec%iprcparm(mld_sub_restr_) == psb_halo_) then
call psb_ovrl(ty,prec%desc_data,info,&
& update=psb_sum_,work=aux)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_ovrl'
goto 9999
end if
else if (prec%iprcparm(mld_sub_restr_) /= psb_none_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_')
goto 9999
end if
case default
info=psb_err_iarg_invalid_i_
int_err(1)=6
ch_err(2:2)=trans
goto 9999
end select
!
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
!
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if ((6*isz) <= size(work)) then
else if ((4*isz) <= size(work)) then
deallocate(ww,tx,ty)
else if ((3*isz) <= size(work)) then
deallocate(aux)
else
deallocate(ww,aux,tx,ty)
endif
end if
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_smoother_type_')
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_das_aply

270
mlprec/mld_das_bld.f90
Unescape Escape View File

@ -1,270 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_das_bld.f90
!
! Subroutine: mld_das_bld
! Version: real
!
! This routine builds Additive Schwarz (AS) preconditioners. If the AS
! preconditioner is actually the block-Jacobi one, the routine makes only a
! copy of the descriptor of the original matrix and then calls mld_fact_bld
! to perform an LU or ILU factorization of the diagonal blocks of the
! distributed matrix.
!
!
! Arguments:
! a - type(psb_dspmat_type), input.
! The sparse matrix structure containing the local part of the
! matrix to be preconditioned.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of the sparse matrix a.
! p - type(mld_dbaseprec_type), input/output.
! The 'base preconditioner' data structure containing the local
! part of the preconditioner or solver to be built.
! upd - character, input.
! If upd='F' then the preconditioner is built from scratch;
! if upd=T' then the matrix to be preconditioned has the same
! sparsity pattern of a matrix that has been previously
! preconditioned, hence some information is reused in building
! the new preconditioner.
! info - integer, output.
! Error code.
!
subroutine mld_das_bld(a,desc_a,p,upd,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_das_bld
Implicit None
! Arguments
type(psb_dspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
type(mld_dbaseprec_type), intent(inout) :: p
character, intent(in) :: upd
integer, intent(out) :: info
! Local variables
integer :: ptype,novr
integer :: icomm
Integer :: np,me,nnzero,ictxt, int_err(5),&
& tot_recv, n_row,n_col,nhalo, err_act, data_
type(psb_dspmat_type) :: blck
integer :: debug_level, debug_unit
character(len=20) :: name, ch_err
name='mld_as_bld'
if(psb_get_errstatus() /= 0) return
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
If (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' start ', upd
ictxt = psb_cd_get_context(desc_a)
icomm = psb_cd_get_mpic(desc_a)
Call psb_info(ictxt, me, np)
tot_recv=0
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
nnzero = a%get_nzeros()
nhalo = n_col-n_row
ptype = p%iprcparm(mld_smoother_type_)
novr = p%iprcparm(mld_sub_ovr_)
select case (ptype)
case(mld_bjac_)
!
! Block Jacobi
!
data_ = psb_no_comm_
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling desccpy'
if (upd == 'F') then
call psb_cdcpy(desc_a,p%desc_data,info)
If(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' done cdcpy'
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Early return: P>=3 N_OVR=0'
endif
call mld_fact_bld(a,p,upd,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_fact_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(mld_as_)
!
! Additive Schwarz
!
if (novr < 0) then
info=psb_err_invalid_ovr_num_
int_err(1)=novr
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
if ((novr == 0).or.(np == 1)) then
!
! Actually, this is just block Jacobi
!
data_ = psb_no_comm_
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling desccpy'
if (upd == 'F') then
call psb_cdcpy(desc_a,p%desc_data,info)
If(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' done cdcpy'
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Early return: P>=3 N_OVR=0'
endif
call blck%csall(0,0,info,1)
else
If (upd == 'F') Then
!
! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_).
! This is done by psb_cdbldext (interface to psb_cdovr), which is
! independent of CSR, and has been placed in the tools directory
! of PSBLAS, instead of the mlprec directory of MLD2P4, because it
! might be used independently of the AS preconditioner, to build
! a descriptor for an extended stencil in a PDE solver.
!
call psb_cdbldext(a,desc_a,novr,p%desc_data,info,extype=psb_ovt_asov_)
if(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' From cdbldext _:',psb_cd_get_local_rows(p%desc_data),&
& psb_cd_get_local_cols(p%desc_data)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_cdbldext'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
Endif
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Before sphalo '
!
! Retrieve the remote sparse matrix rows required for the AS extended
! matrix
data_ = psb_comm_ext_
Call psb_sphalo(a,p%desc_data,blck,info,data=data_,rowscale=.true.)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_sphalo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (debug_level >=psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'After psb_sphalo ',&
& blck%get_nrows(), blck%get_nzeros()
End if
call mld_fact_bld(a,p,upd,info,blck=blck)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_fact_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case default
info=psb_err_internal_error_
ch_err='Invalid ptype'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
End select
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),'Done'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
Return
End Subroutine mld_das_bld

189
mlprec/mld_dbaseprec_aply.f90
Unescape Escape View File

@ -1,189 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_dbaseprec_aply.f90
!
! Subroutine: mld_dbaseprec_aply
! Version: real
!
! This routine applies a base preconditioner by computing
!
! Y = beta*Y + alpha*op(K^(-1))*X,
! where
! - K is the base preconditioner, stored in prec,
! - op(K^(-1)) is K^(-1) or its transpose, according to the value of trans,
! - X and Y are vectors,
! - alpha and beta are scalars.
!
! The routine is used by mld_dmlprec_aply, to apply the multilevel preconditioners,
! or directly by mld_dprec_aply, to apply the basic one-level preconditioners (diagonal,
! block-Jacobi or additive Schwarz). It also manages the case of no preconditioning.
!
!
! Arguments:
! alpha - real(psb_dpk_), input.
! The scalar alpha.
! prec - type(mld_dbaseprec_type), input.
! The base preconditioner data structure containing the local part
! of the preconditioner K.
! x - real(psb_dpk_), dimension(:), input.
! The local part of the vector X.
! beta - real(psb_dpk_), input.
! The scalar beta.
! y - real(psb_dpk_), dimension(:), input/output.
! The local part of the vector Y.
! desc_data - type(psb_desc_type), input.
! The communication descriptor associated to the matrix to be
! preconditioned.
! trans - character, optional.
! If trans='N','n' then op(K^(-1)) = K^(-1);
! if trans='T','t' then op(K^(-1)) = K^(-T) (transpose of K^(-1)).
! work - real(psb_dpk_), dimension (:), optional, target.
! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data).
! info - integer, output.
! Error code.
!
subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_dbaseprec_aply
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_dbaseprec_type), intent(in) :: prec
real(psb_dpk_),intent(in) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1) :: trans
real(psb_dpk_),target :: work(:)
integer, intent(out) :: info
! Local variables
real(psb_dpk_), pointer :: ww(:)
integer :: ictxt, np, me, err_act
integer :: n_row, int_err(5)
character(len=20) :: name, ch_err
character :: trans_
name='mld_dbaseprec_aply'
info = psb_success_
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc_data)
call psb_info(ictxt, me, np)
trans_= psb_toupper(trans)
select case(trans_)
case('N','T','C')
! Ok
case default
info=psb_err_iarg_invalid_i_
int_err(1)=6
ch_err(2:2)=trans
goto 9999
end select
select case(prec%iprcparm(mld_smoother_type_))
case(mld_noprec_)
!
! No preconditioner
!
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
case(mld_diag_)
!
! Diagonal preconditioner
!
if (size(work) >= size(x)) then
ww => work
else
allocate(ww(size(x)),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_request_,name,i_err=(/size(x),0,0,0,0/),a_err='real(psb_dpk_)')
goto 9999
end if
end if
n_row = psb_cd_get_local_rows(desc_data)
ww(1:n_row) = x(1:n_row)*prec%d(1:n_row)
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
if (size(work) < size(x)) then
deallocate(ww,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate')
goto 9999
end if
end if
case(mld_bjac_,mld_as_)
!
! Additive Schwarz preconditioner (including block-Jacobi as special case)
!
call mld_as_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_as_aply'
goto 9999
end if
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_smoother_type_')
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_dbaseprec_aply

215
mlprec/mld_dbaseprec_bld.f90
Unescape Escape View File

@ -1,215 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_dbaseprec_bld.f90
!
! Subroutine: mld_dbaseprec_bld
! Version: real
!
! This routine builds a 'base preconditioner' related to a matrix A.
! In a multilevel framework, it is called by mld_mlprec_bld to build the
! base preconditioner at each level.
!
! Details on the base preconditioner to be built are stored in the iprcparm
! field of the base preconditioner data structure (for a description of this
! data structure see mld_prec_type.f90).
!
!
! Arguments:
! a - type(psb_dspmat_type).
! The sparse matrix structure containing the local part of the
! matrix A to be preconditioned.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of a.
! p - type(mld_dbaseprec_type), input/output.
! The 'base preconditioner' data structure containing the local
! part of the preconditioner at the selected level.
! info - integer, output.
! Error code.
! upd - character, input, optional.
! If upd='F' then the base preconditioner is built from
! scratch; if upd=T' then the matrix to be preconditioned
! has the same sparsity pattern of a matrix that has been
! previously preconditioned, hence some information is reused
! in building the new preconditioner.
!
subroutine mld_dbaseprec_bld(a,desc_a,p,info,upd)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_dbaseprec_bld
Implicit None
! Arguments
type(psb_dspmat_type), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_dbaseprec_type),intent(inout) :: p
integer, intent(out) :: info
character, intent(in), optional :: upd
! Local variables
Integer :: err, n_row, n_col,ictxt, me,np,mglob, err_act
character :: iupd
integer :: debug_level, debug_unit
character(len=20) :: name, ch_err
if (psb_get_errstatus() /= 0) return
name = 'mld_dbaseprec_bld'
info=psb_success_
err=0
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc_a)
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
mglob = psb_cd_get_global_rows(desc_a)
call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' start'
if (present(upd)) then
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),'UPD ', upd
if ((psb_toupper(UPD) == 'F').or.(psb_toupper(UPD) == 'T')) then
IUPD=psb_toupper(UPD)
else
IUPD='F'
endif
else
IUPD='F'
endif
!
! Should add check to ensure all procs have the same...
!
call mld_check_def(p%iprcparm(mld_smoother_type_),'base_prec',&
& mld_diag_,is_legal_base_prec)
call psb_nullify_desc(p%desc_data)
select case(p%iprcparm(mld_smoother_type_))
case (mld_noprec_)
! No preconditioner
! Do nothing
call psb_cdcpy(desc_a,p%desc_data,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case (mld_diag_)
! Diagonal preconditioner
call mld_diag_bld(a,desc_a,p,info)
if(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': out of mld_diag_bld'
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_diag_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(mld_bjac_,mld_as_)
! Additive Schwarz preconditioners/smoothers
call mld_check_def(p%iprcparm(mld_sub_ovr_),'overlap',&
& 0,is_legal_n_ovr)
call mld_check_def(p%iprcparm(mld_sub_restr_),'restriction',&
& psb_halo_,is_legal_restrict)
call mld_check_def(p%iprcparm(mld_sub_prol_),'prolongator',&
& psb_none_,is_legal_prolong)
call mld_check_def(p%iprcparm(mld_sub_ren_),'renumbering',&
& mld_renum_none_,is_legal_renum)
call mld_check_def(p%iprcparm(mld_sub_solve_),'fact',&
& mld_ilu_n_,is_legal_ml_fact)
! Set parameters for using SuperLU_dist on the local submatrices
if (p%iprcparm(mld_sub_solve_) == mld_sludist_) then
p%iprcparm(mld_sub_ovr_) = 0
p%iprcparm(mld_smoother_sweeps_) = 1
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': Calling mld_as_bld'
! Build the local part of the base preconditioner/smoother
call mld_as_bld(a,desc_a,p,iupd,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='mld_as_bld')
goto 9999
end if
case default
info=psb_err_internal_error_
ch_err='Unknown mld_smoother_type_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
p%iprcparm(mld_prec_status_) = mld_prec_built_
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Done'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_dbaseprec_bld

287
mlprec/mld_dilu_bld.f90
Unescape Escape View File

@ -1,287 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_dilu_bld.f90
!
! Subroutine: mld_dilu_bld
! Version: real
!
! This routine computes an incomplete LU (ILU) factorization of the diagonal
! blocks of a distributed matrix. This factorization is used to build the
! 'base preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz
! preconditioner) corresponding to a certain level of a multilevel preconditioner.
!
! The following factorizations are available:
! - ILU(k), i.e. ILU factorization with fill-in level k,
! - MILU(k), i.e. modified ILU factorization with fill-in level k,
! - ILU(k,t), i.e. ILU with threshold (i.e. drop tolerance) t and k additional
! entries in each row of the L and U factors with respect to the initial
! sparsity pattern.
! Note that the meaning of k in ILU(k,t) is different from that in ILU(k) and
! MILU(k).
!
! For details on the above factorizations see
! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition,
! SIAM, 2003, Chapter 10.
!
! Note that that this routine handles the ILU(0) factorization separately,
! through mld_ilu0_fact, for performance reasons.
!
!
! Arguments:
! a - type(psb_dspmat_type), input.
! The sparse matrix structure containing the local matrix.
! Note that if p%iprcparm(mld_sub_ovr_) > 0, i.e. the
! 'base' Additive Schwarz preconditioner has overlap greater than
! 0, and p%iprcparm(mld_sub_ren_) = 0, i.e. a reordering of the
! matrix has not been performed (see mld_fact_bld), then a contains
! only the 'original' local part of the distributed matrix,
! i.e. the rows of the matrix held by the calling process according
! to the initial data distribution.
! p - type(mld_dbaseprec_type), input/output.
! The 'base preconditioner' data structure. In input, p%iprcparm
! contains information on the type of factorization to be computed.
! In output, p%av(mld_l_pr_) and p%av(mld_u_pr_) contain the
! incomplete L and U factors (without their diagonals), and p%d
! contains the diagonal of the incomplete U factor. For more
! details on p see its description in mld_prec_type.f90.
! info - integer, output.
! Error code.
! blck - type(psb_dspmat_type), input, optional.
! The sparse matrix structure containing the remote rows of the
! distributed matrix, that have been retrieved by mld_as_bld
! to build an Additive Schwarz base preconditioner with overlap
! greater than 0. If the overlap is 0 or the matrix has been reordered
! (see mld_fact_bld), then blck does not contain any row.
!
subroutine mld_dilu_bld(a,p,upd,info,blck)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_dilu_bld
implicit none
! Arguments
type(psb_dspmat_type), intent(in), target :: a
type(mld_dbaseprec_type), intent(inout) :: p
character, intent(in) :: upd
integer, intent(out) :: info
type(psb_dspmat_type), intent(in), optional :: blck
! Local Variables
integer :: i, nztota, err_act, n_row, nrow_a
character :: trans, unitd
integer :: debug_level, debug_unit
integer :: ictxt,np,me
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=psb_success_
name='mld_dilu_bld'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(p%desc_data)
call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' start'
trans = 'N'
unitd = 'U'
n_row = psb_cd_get_local_rows(p%desc_data)
if (psb_toupper(upd) == 'F') then
!
! Check the memory available to hold the incomplete L and U factors
! and allocate it if needed
!
if (allocated(p%av)) then
if (size(p%av) < mld_bp_ilu_avsz_) then
do i=1, size(p%av)
call p%av(i)%free()
enddo
deallocate(p%av,stat=info)
endif
end if
if (.not.allocated(p%av)) then
allocate(p%av(mld_max_avsz_),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
endif
nrow_a = a%get_nrows()
nztota = a%get_nzeros()
if (present(blck)) then
nztota = nztota + blck%get_nzeros()
end if
call p%av(mld_l_pr_)%csall(n_row,n_row,info,nztota)
if (info == psb_success_) call p%av(mld_u_pr_)%csall(n_row,n_row,info,nztota)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (allocated(p%d)) then
if (size(p%d) < n_row) then
deallocate(p%d)
endif
endif
if (.not.allocated(p%d)) then
allocate(p%d(n_row),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
endif
select case(p%iprcparm(mld_sub_solve_))
case (mld_ilu_t_)
!
! ILU(k,t)
!
select case(p%iprcparm(mld_sub_fillin_))
case(:-1)
! Error: fill-in <= -1
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,p%iprcparm(mld_sub_fillin_),0,0,0/))
goto 9999
case(0:)
! Fill-in >= 0
call mld_ilut_fact(p%iprcparm(mld_sub_fillin_),p%rprcparm(mld_sub_iluthrs_),&
& a, p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck)
end select
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_ilut_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(mld_ilu_n_,mld_milu_n_)
!
! ILU(k) and MILU(k)
!
select case(p%iprcparm(mld_sub_fillin_))
case(:-1)
! Error: fill-in <= -1
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,p%iprcparm(mld_sub_fillin_),0,0,0/))
goto 9999
case(0)
! Fill-in 0
! Separate implementation of ILU(0) for better performance.
! There seems to be a problem with the separate implementation of MILU(0),
! contained into mld_ilu0_fact. This must be investigated. For the time being,
! resort to the implementation of MILU(k) with k=0.
if (p%iprcparm(mld_sub_solve_) == mld_ilu_n_) then
call mld_ilu0_fact(p%iprcparm(mld_sub_solve_),a,p%av(mld_l_pr_),p%av(mld_u_pr_),&
& p%d,info,blck=blck,upd=upd)
else
call mld_iluk_fact(p%iprcparm(mld_sub_fillin_),p%iprcparm(mld_sub_solve_),&
& a,p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck)
endif
case(1:)
! Fill-in >= 1
! The same routine implements both ILU(k) and MILU(k)
call mld_iluk_fact(p%iprcparm(mld_sub_fillin_),p%iprcparm(mld_sub_solve_),&
& a,p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck)
end select
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_iluk_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case default
! If we end up here, something was wrong up in the call chain.
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end select
else
! Here we should add checks for reuse of L and U.
! For the time being just throw an error.
info = 31
call psb_errpush(info, name, i_err=(/3,0,0,0,0/),a_err=upd)
goto 9999
!
! What is an update of a factorization??
! A first attempt could be to reuse EXACTLY the existing indices
! as if it was an ILU(0) (since, effectively, the sparsity pattern
! should not grow beyond what is already there).
!
call mld_ilu0_fact(p%iprcparm(mld_sub_solve_),a,&
& p%av(mld_l_pr_),p%av(mld_u_pr_),&
& p%d,info,blck=blck,upd=upd)
end if
call p%av(mld_l_pr_)%set_asb()
call p%av(mld_l_pr_)%trim()
call p%av(mld_u_pr_)%set_asb()
call p%av(mld_u_pr_)%trim()
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_dilu_bld

12
mlprec/mld_move_alloc_mod.f90
Unescape Escape View File

@ -71,12 +71,12 @@ contains
call mld_precfree(b,info) call mld_precfree(b,info)
if (info == psb_success_) call psb_move_alloc(a%iprcparm,b%iprcparm,info) if (info == psb_success_) call psb_move_alloc(a%iprcparm,b%iprcparm,info)
if (info == psb_success_) call psb_move_alloc(a%rprcparm,b%rprcparm,info) !!$ if (info == psb_success_) call psb_move_alloc(a%rprcparm,b%rprcparm,info)
if (info == psb_success_) call psb_move_alloc(a%desc_data,b%desc_data,info) !!$ if (info == psb_success_) call psb_move_alloc(a%desc_data,b%desc_data,info)
if (info == psb_success_) call psb_move_alloc(a%perm,b%perm,info) !!$ if (info == psb_success_) call psb_move_alloc(a%perm,b%perm,info)
if (info == psb_success_) call psb_move_alloc(a%invperm,b%invperm,info) !!$ if (info == psb_success_) call psb_move_alloc(a%invperm,b%invperm,info)
if (info == psb_success_) call psb_move_alloc(a%d,b%d,info) !!$ if (info == psb_success_) call psb_move_alloc(a%d,b%d,info)
call move_alloc(a%av,b%av) !!$ call move_alloc(a%av,b%av)
if (info /= psb_success_) then if (info /= psb_success_) then
write(0,*) 'Error in baseprec_:transfer',info write(0,*) 'Error in baseprec_:transfer',info
end if end if

874
mlprec/mld_s_as_smoother.f03
Unescape Escape View File

@ -0,0 +1,874 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010, 2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
!
!
!
!
!
!
module mld_s_as_smoother
use mld_s_prec_type
type, extends(mld_s_base_smoother_type) :: mld_s_as_smoother_type
! The local solver component is inherited from the
! parent type.
! class(mld_s_base_solver_type), allocatable :: sv
!
type(psb_sspmat_type) :: nd
type(psb_desc_type) :: desc_data
integer :: novr, restr, prol
contains
procedure, pass(sm) :: build => s_as_smoother_bld
procedure, pass(sm) :: apply => s_as_smoother_apply
procedure, pass(sm) :: free => s_as_smoother_free
procedure, pass(sm) :: seti => s_as_smoother_seti
procedure, pass(sm) :: setc => s_as_smoother_setc
procedure, pass(sm) :: setr => s_as_smoother_setr
procedure, pass(sm) :: descr => s_as_smoother_descr
procedure, pass(sm) :: sizeof => s_as_smoother_sizeof
end type mld_s_as_smoother_type
private :: s_as_smoother_bld, s_as_smoother_apply, &
& s_as_smoother_free, s_as_smoother_seti, &
& s_as_smoother_setc, s_as_smoother_setr,&
& s_as_smoother_descr, s_as_smoother_sizeof
character(len=6), parameter, private :: &
& restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/)
character(len=12), parameter, private :: &
& prolong_names(0:3)=(/'none ','sum ','average ','square root'/)
contains
subroutine s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
class(mld_s_as_smoother_type), intent(in) :: sm
real(psb_spk_),intent(in) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
integer, intent(in) :: sweeps
real(psb_spk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
integer :: n_row,n_col, nrow_d, i
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me, err_act,isz,int_err(5)
character :: trans_
character(len=20) :: name='s_as_smoother_apply', ch_err
call psb_erractionsave(err_act)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
case('T','C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,name)
goto 9999
end select
if (.not.allocated(sm%sv)) then
info = 1121
call psb_errpush(info,name)
goto 9999
end if
n_row = psb_cd_get_local_rows(sm%desc_data)
n_col = psb_cd_get_local_cols(sm%desc_data)
nrow_d = psb_cd_get_local_rows(desc_data)
isz=max(n_row,N_COL)
if ((6*isz) <= size(work)) then
ww => work(1:isz)
tx => work(isz+1:2*isz)
ty => work(2*isz+1:3*isz)
aux => work(3*isz+1:)
else if ((4*isz) <= size(work)) then
aux => work(1:)
allocate(ww(isz),tx(isz),ty(isz),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),&
& a_err='real(psb_spk_)')
goto 9999
end if
else if ((3*isz) <= size(work)) then
ww => work(1:isz)
tx => work(isz+1:2*isz)
ty => work(2*isz+1:3*isz)
allocate(aux(4*isz),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),&
& a_err='real(psb_spk_)')
goto 9999
end if
else
allocate(ww(isz),tx(isz),ty(isz),&
&aux(4*isz),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),&
& a_err='real(psb_spk_)')
goto 9999
end if
endif
if ((sm%novr == 0).and.(sweeps == 1)) then
!
! Shortcut: in this case it's just the same
! as Block Jacobi.
!
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in sub_aply Jacobi Sweeps = 1')
goto 9999
endif
else
tx(1:nrow_d) = x(1:nrow_d)
tx(nrow_d+1:isz) = szero
if (sweeps == 1) then
select case(trans_)
case('N')
!
! Get the overlap entries of tx (tx == x)
!
if (sm%restr == psb_halo_) then
call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_halo'
goto 9999
end if
else if (sm%restr /= psb_none_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_')
goto 9999
end if
case('T','C')
!
! With transpose, we have to do it here
!
select case (sm%prol)
case(psb_none_)
!
! Do nothing
case(psb_sum_)
!
! The transpose of sum is halo
!
call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_halo'
goto 9999
end if
case(psb_avg_)
!
! Tricky one: first we have to scale the overlap entries,
! which we can do by assignind mode=0, i.e. no communication
! (hence only scaling), then we do the halo
!
call psb_ovrl(tx,sm%desc_data,info,&
& update=psb_avg_,work=aux,mode=0)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_ovrl'
goto 9999
end if
call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_halo'
goto 9999
end if
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_')
goto 9999
end select
case default
info=psb_err_iarg_invalid_i_
int_err(1)=6
ch_err(2:2)=trans
goto 9999
end select
call sm%sv%apply(sone,tx,szero,ty,sm%desc_data,trans_,aux,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error in sub_aply Jacobi Sweeps = 1')
goto 9999
endif
select case(trans_)
case('N')
select case (sm%prol)
case(psb_none_)
!
! Would work anyway, but since it is supposed to do nothing ...
! call psb_ovrl(ty,sm%desc_data,info,&
! & update=sm%prol,work=aux)
case(psb_sum_,psb_avg_)
!
! Update the overlap of ty
!
call psb_ovrl(ty,sm%desc_data,info,&
& update=sm%prol,work=aux)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_ovrl'
goto 9999
end if
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_')
goto 9999
end select
case('T','C')
!
! With transpose, we have to do it here
!
if (sm%restr == psb_halo_) then
call psb_ovrl(ty,sm%desc_data,info,&
& update=psb_sum_,work=aux)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_ovrl'
goto 9999
end if
else if (sm%restr /= psb_none_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_')
goto 9999
end if
case default
info=psb_err_iarg_invalid_i_
int_err(1)=6
ch_err(2:2)=trans
goto 9999
end select
else if (sweeps > 1) then
!
!
! Apply prec%iprcparm(mld_smoother_sweeps_) sweeps of a block-Jacobi solver
! to compute an approximate solution of a linear system.
!
!
ty = szero
do i=1, sweeps
select case(trans_)
case('N')
!
! Get the overlap entries of tx (tx == x)
!
if (sm%restr == psb_halo_) then
call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_halo'
goto 9999
end if
else if (sm%restr /= psb_none_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_')
goto 9999
end if
case('T','C')
!
! With transpose, we have to do it here
!
select case (sm%prol)
case(psb_none_)
!
! Do nothing
case(psb_sum_)
!
! The transpose of sum is halo
!
call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_halo'
goto 9999
end if
case(psb_avg_)
!
! Tricky one: first we have to scale the overlap entries,
! which we can do by assignind mode=0, i.e. no communication
! (hence only scaling), then we do the halo
!
call psb_ovrl(tx,sm%desc_data,info,&
& update=psb_avg_,work=aux,mode=0)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_ovrl'
goto 9999
end if
call psb_halo(tx,sm%desc_data,info,work=aux,data=psb_comm_ext_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_halo'
goto 9999
end if
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_')
goto 9999
end select
case default
info=psb_err_iarg_invalid_i_
int_err(1)=6
ch_err(2:2)=trans
goto 9999
end select
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
ww(1:n_row) = tx(1:n_row)
call psb_spmm(-sone,sm%nd,tx,sone,ww,sm%desc_data,info,work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info)
if (info /= psb_success_) exit
select case(trans_)
case('N')
select case (sm%prol)
case(psb_none_)
!
! Would work anyway, but since it is supposed to do nothing ...
! call psb_ovrl(ty,sm%desc_data,info,&
! & update=sm%prol,work=aux)
case(psb_sum_,psb_avg_)
!
! Update the overlap of ty
!
call psb_ovrl(ty,sm%desc_data,info,&
& update=sm%prol,work=aux)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_ovrl'
goto 9999
end if
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_')
goto 9999
end select
case('T','C')
!
! With transpose, we have to do it here
!
if (sm%restr == psb_halo_) then
call psb_ovrl(ty,sm%desc_data,info,&
& update=psb_sum_,work=aux)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_ovrl'
goto 9999
end if
else if (sm%restr /= psb_none_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_')
goto 9999
end if
case default
info=psb_err_iarg_invalid_i_
int_err(1)=6
ch_err(2:2)=trans
goto 9999
end select
end do
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
else
info = psb_err_iarg_neg_
call psb_errpush(info,name,&
& i_err=(/2,sweeps,0,0,0/))
goto 9999
end if
!
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
!
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
end if
if ((6*isz) <= size(work)) then
else if ((4*isz) <= size(work)) then
deallocate(ww,tx,ty)
else if ((3*isz) <= size(work)) then
deallocate(aux)
else
deallocate(ww,aux,tx,ty)
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_as_smoother_apply
subroutine s_as_smoother_bld(a,desc_a,sm,upd,info)
use psb_sparse_mod
Implicit None
! Arguments
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_s_as_smoother_type), intent(inout) :: sm
character, intent(in) :: upd
integer, intent(out) :: info
! Local variables
type(psb_sspmat_type) :: blck, atmp
integer :: n_row,n_col, nrow_a, nhalo, novr, data_
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='s_as_smoother_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' start'
novr = sm%novr
if (novr < 0) then
info=psb_err_invalid_ovr_num_
call psb_errpush(info,name,i_err=(/novr,0,0,0,0,0/))
goto 9999
endif
if ((novr == 0).or.(np == 1)) then
if (psb_toupper(upd) == 'F') then
call psb_cdcpy(desc_a,sm%desc_data,info)
If(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' sone cdcpy'
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Early return: P>=3 N_OVR=0'
endif
call blck%csall(0,0,info,1)
else
If (psb_toupper(upd) == 'F') Then
!
! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_).
! This is done by psb_cdbldext (interface to psb_cdovr), which is
! independent of CSR, and has been placed in the tools directory
! of PSBLAS, instead of the mlprec directory of MLD2P4, because it
! might be used independently of the AS preconditioner, to build
! a descriptor for an extended stencil in a PDE solver.
!
call psb_cdbldext(a,desc_a,novr,sm%desc_data,info,extype=psb_ovt_asov_)
if(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' From cdbldext _:',psb_cd_get_local_rows(sm%desc_data),&
& psb_cd_get_local_cols(sm%desc_data)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_cdbldext'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
Endif
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Before sphalo '
!
! Retrieve the remote sparse matrix rows required for the AS extended
! matrix
data_ = psb_comm_ext_
Call psb_sphalo(a,sm%desc_data,blck,info,data=data_,rowscale=.true.)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_sphalo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (debug_level >=psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'After psb_sphalo ',&
& blck%get_nrows(), blck%get_nzeros()
End if
if (info == psb_success_) &
& call sm%sv%build(a,sm%desc_data,upd,info,blck)
nrow_a = a%get_nrows()
n_row = psb_cd_get_local_rows(sm%desc_data)
n_col = psb_cd_get_local_cols(sm%desc_data)
if (info == psb_success_) call a%csclip(sm%nd,info,&
& jmin=nrow_a+1,rscale=.false.,cscale=.false.)
if (info == psb_success_) call blck%csclip(atmp,info,&
& jmin=nrow_a+1,rscale=.false.,cscale=.false.)
if (info == psb_success_) call psb_rwextd(n_row,sm%nd,info,b=atmp)
if (info == psb_success_) call sm%nd%cscnv(info,&
& type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='clip & psb_spcnv csr 4')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_as_smoother_bld
subroutine s_as_smoother_seti(sm,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_as_smoother_type), intent(inout) :: sm
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='s_as_smoother_seti'
info = psb_success_
call psb_erractionsave(err_act)
select case(what)
!!$ case(mld_smoother_sweeps_)
!!$ sm%sweeps = val
case(mld_sub_ovr_)
sm%novr = val
case(mld_sub_restr_)
sm%restr = val
case(mld_sub_prol_)
sm%prol = val
case default
if (allocated(sm%sv)) then
call sm%sv%set(what,val,info)
!!$ else
!!$ write(0,*) trim(name),' Missing component, not setting!'
!!$ info = 1121
end if
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_as_smoother_seti
subroutine s_as_smoother_setc(sm,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_as_smoother_type), intent(inout) :: sm
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='s_as_smoother_setc'
info = psb_success_
call psb_erractionsave(err_act)
call mld_stringval(val,ival,info)
if (info == psb_success_) call sm%set(what,ival,info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info, name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_as_smoother_setc
subroutine s_as_smoother_setr(sm,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_as_smoother_type), intent(inout) :: sm
integer, intent(in) :: what
real(psb_spk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='s_as_smoother_setr'
call psb_erractionsave(err_act)
info = psb_success_
if (allocated(sm%sv)) then
call sm%sv%set(what,val,info)
else
!!$ write(0,*) trim(name),' Missing component, not setting!'
!!$ info = 1121
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_as_smoother_setr
subroutine s_as_smoother_free(sm,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_as_smoother_type), intent(inout) :: sm
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='s_as_smoother_free'
call psb_erractionsave(err_act)
info = psb_success_
if (allocated(sm%sv)) then
call sm%sv%free(info)
if (info == psb_success_) deallocate(sm%sv,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
end if
call sm%nd%free()
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_as_smoother_free
subroutine s_as_smoother_descr(sm,info,iout)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_as_smoother_type), intent(in) :: sm
integer, intent(out) :: info
integer, intent(in), optional :: iout
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_s_as_smoother_descr'
integer :: iout_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = 6
endif
write(iout_,*) ' Additive Schwarz with ',&
& sm%novr, ' overlap layers.'
write(iout_,*) ' Restrictor: ',restrict_names(sm%restr)
write(iout_,*) ' Prolongator: ',prolong_names(sm%prol)
write(iout_,*) ' Local solver:'
if (allocated(sm%sv)) then
call sm%sv%descr(info,iout_)
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_as_smoother_descr
function s_as_smoother_sizeof(sm) result(val)
use psb_sparse_mod
implicit none
! Arguments
class(mld_s_as_smoother_type), intent(in) :: sm
integer(psb_long_int_k_) :: val
integer :: i
val = psb_sizeof_int
if (allocated(sm%sv)) val = val + sm%sv%sizeof()
val = val + sm%nd%sizeof()
return
end function s_as_smoother_sizeof
end module mld_s_as_smoother

466
mlprec/mld_s_diag_solver.f03
Unescape Escape View File

@ -0,0 +1,466 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010, 2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
!
!
!
!
!
!
module mld_s_diag_solver
use mld_s_prec_type
type, extends(mld_s_base_solver_type) :: mld_s_diag_solver_type
real(psb_spk_), allocatable :: d(:)
contains
procedure, pass(sv) :: build => s_diag_solver_bld
procedure, pass(sv) :: apply => s_diag_solver_apply
procedure, pass(sv) :: free => s_diag_solver_free
procedure, pass(sv) :: seti => s_diag_solver_seti
procedure, pass(sv) :: setc => s_diag_solver_setc
procedure, pass(sv) :: setr => s_diag_solver_setr
procedure, pass(sv) :: descr => s_diag_solver_descr
procedure, pass(sv) :: sizeof => s_diag_solver_sizeof
end type mld_s_diag_solver_type
private :: s_diag_solver_bld, s_diag_solver_apply, &
& s_diag_solver_free, s_diag_solver_seti, &
& s_diag_solver_setc, s_diag_solver_setr,&
& s_diag_solver_descr, s_diag_solver_sizeof
contains
subroutine s_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
class(mld_s_diag_solver_type), intent(in) :: sv
real(psb_spk_),intent(in) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
integer :: n_row,n_col
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='s_diag_solver_apply'
call psb_erractionsave(err_act)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
case('T','C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,name)
goto 9999
end select
n_row = psb_cd_get_local_rows(desc_data)
n_col = psb_cd_get_local_cols(desc_data)
if (beta == dzero) then
if (alpha == dzero) then
y(1:n_row) = dzero
else if (alpha == done) then
do i=1, n_row
y(i) = sv%d(i) * x(i)
end do
else if (alpha == -done) then
do i=1, n_row
y(i) = -sv%d(i) * x(i)
end do
else
do i=1, n_row
y(i) = alpha * sv%d(i) * x(i)
end do
end if
else if (beta == done) then
if (alpha == dzero) then
!y(1:n_row) = dzero
else if (alpha == done) then
do i=1, n_row
y(i) = sv%d(i) * x(i) + y(i)
end do
else if (alpha == -done) then
do i=1, n_row
y(i) = -sv%d(i) * x(i) + y(i)
end do
else
do i=1, n_row
y(i) = alpha * sv%d(i) * x(i) + y(i)
end do
end if
else if (beta == -done) then
if (alpha == dzero) then
y(1:n_row) = -y(1:n_row)
else if (alpha == done) then
do i=1, n_row
y(i) = sv%d(i) * x(i) - y(i)
end do
else if (alpha == -done) then
do i=1, n_row
y(i) = -sv%d(i) * x(i) - y(i)
end do
else
do i=1, n_row
y(i) = alpha * sv%d(i) * x(i) - y(i)
end do
end if
else
if (alpha == dzero) then
y(1:n_row) = beta *y(1:n_row)
else if (alpha == done) then
do i=1, n_row
y(i) = sv%d(i) * x(i) + beta*y(i)
end do
else if (alpha == -done) then
do i=1, n_row
y(i) = -sv%d(i) * x(i) + beta*y(i)
end do
else
do i=1, n_row
y(i) = alpha * sv%d(i) * x(i) + beta*y(i)
end do
end if
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_diag_solver_apply
subroutine s_diag_solver_bld(a,desc_a,sv,upd,info,b)
use psb_sparse_mod
Implicit None
! Arguments
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_s_diag_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer, intent(out) :: info
type(psb_sspmat_type), intent(in), target, optional :: b
! Local variables
integer :: n_row,n_col, nrow_a, nztota
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='s_diag_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' start'
n_row = psb_cd_get_local_rows(desc_a)
nrow_a = a%get_nrows()
if (allocated(sv%d)) then
if (size(sv%d) < n_row) then
deallocate(sv%d)
endif
endif
if (.not.allocated(sv%d)) then
allocate(sv%d(n_row),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
endif
call a%get_diag(sv%d,info)
if (present(b)) then
if (info == psb_success_) call b%get_diag(sv%d(nrow_a+1:), info)
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='get_diag')
goto 9999
end if
do i=1,n_row
if (sv%d(i) == dzero) then
sv%d(i) = done
else
sv%d(i) = done/sv%d(i)
end if
end do
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_diag_solver_bld
subroutine s_diag_solver_seti(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_diag_solver_type), intent(inout) :: sv
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='s_diag_solver_seti'
info = psb_success_
!!$ call psb_erractionsave(err_act)
!!$
!!$ select case(what)
!!$ case(mld_sub_solve_)
!!$ sv%fact_type = val
!!$ case(mld_sub_fillin_)
!!$ sv%fill_in = val
!!$ case default
!!$ write(0,*) name,': Error: invalid WHAT'
!!$ info = -2
!!$ end select
!!$
!!$ call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_diag_solver_seti
subroutine s_diag_solver_setc(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_diag_solver_type), intent(inout) :: sv
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='s_diag_solver_setc'
info = psb_success_
!!$ call psb_erractionsave(err_act)
!!$
!!$
!!$ call mld_stringval(val,ival,info)
!!$ if (info == psb_success_) call sv%set(what,ival,info)
!!$ if (info /= psb_success_) then
!!$ info = psb_err_from_subroutine_
!!$ call psb_errpush(info, name)
!!$ goto 9999
!!$ end if
!!$
!!$ call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_diag_solver_setc
subroutine s_diag_solver_setr(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_diag_solver_type), intent(inout) :: sv
integer, intent(in) :: what
real(psb_spk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='s_diag_solver_setr'
info = psb_success_
!!$ call psb_erractionsave(err_act)
!!$
!!$ select case(what)
!!$ case(mld_sub_iluthrs_)
!!$ sv%thresh = val
!!$ case default
!!$ write(0,*) name,': Error: invalid WHAT'
!!$ info = -2
!!$ goto 9999
!!$ end select
!!$
!!$ call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_diag_solver_setr
subroutine s_diag_solver_free(sv,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_diag_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='s_diag_solver_free'
call psb_erractionsave(err_act)
info = psb_success_
if (allocated(sv%d)) then
deallocate(sv%d,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_diag_solver_free
subroutine s_diag_solver_descr(sv,info,iout)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_diag_solver_type), intent(in) :: sv
integer, intent(out) :: info
integer, intent(in), optional :: iout
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_s_diag_solver_descr'
integer :: iout_
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = 6
endif
write(iout_,*) ' Diagonal local solver '
return
end subroutine s_diag_solver_descr
function s_diag_solver_sizeof(sv) result(val)
use psb_sparse_mod
implicit none
! Arguments
class(mld_s_diag_solver_type), intent(in) :: sv
integer(psb_long_int_k_) :: val
integer :: i
val = 0
if (allocated(sv%d)) val = val + psb_sizeof_sp * size(sv%d)
return
end function s_diag_solver_sizeof
end module mld_s_diag_solver

606
mlprec/mld_s_ilu_solver.f03
Unescape Escape View File

@ -0,0 +1,606 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010, 2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
!
!
!
!
!
!
module mld_s_ilu_solver
use mld_s_prec_type
type, extends(mld_s_base_solver_type) :: mld_s_ilu_solver_type
type(psb_sspmat_type) :: l, u
real(psb_spk_), allocatable :: d(:)
integer :: fact_type, fill_in
real(psb_spk_) :: thresh
contains
procedure, pass(sv) :: build => s_ilu_solver_bld
procedure, pass(sv) :: apply => s_ilu_solver_apply
procedure, pass(sv) :: free => s_ilu_solver_free
procedure, pass(sv) :: seti => s_ilu_solver_seti
procedure, pass(sv) :: setc => s_ilu_solver_setc
procedure, pass(sv) :: setr => s_ilu_solver_setr
procedure, pass(sv) :: descr => s_ilu_solver_descr
procedure, pass(sv) :: sizeof => s_ilu_solver_sizeof
end type mld_s_ilu_solver_type
private :: s_ilu_solver_bld, s_ilu_solver_apply, &
& s_ilu_solver_free, s_ilu_solver_seti, &
& s_ilu_solver_setc, s_ilu_solver_setr,&
& s_ilu_solver_descr, s_ilu_solver_sizeof
interface mld_ilu0_fact
subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck,upd)
use psb_sparse_mod, only : psb_sspmat_type, psb_spk_
integer, intent(in) :: ialg
integer, intent(out) :: info
type(psb_sspmat_type),intent(in) :: a
type(psb_sspmat_type),intent(inout) :: l,u
type(psb_sspmat_type),intent(in), optional, target :: blck
character, intent(in), optional :: upd
real(psb_spk_), intent(inout) :: d(:)
end subroutine mld_silu0_fact
end interface
interface mld_iluk_fact
subroutine mld_siluk_fact(fill_in,ialg,a,l,u,d,info,blck)
use psb_sparse_mod, only : psb_sspmat_type, psb_spk_
integer, intent(in) :: fill_in,ialg
integer, intent(out) :: info
type(psb_sspmat_type),intent(in) :: a
type(psb_sspmat_type),intent(inout) :: l,u
type(psb_sspmat_type),intent(in), optional, target :: blck
real(psb_spk_), intent(inout) :: d(:)
end subroutine mld_siluk_fact
end interface
interface mld_ilut_fact
subroutine mld_silut_fact(fill_in,thres,a,l,u,d,info,blck)
use psb_sparse_mod, only : psb_sspmat_type, psb_spk_
integer, intent(in) :: fill_in
real(psb_spk_), intent(in) :: thres
integer, intent(out) :: info
type(psb_sspmat_type),intent(in) :: a
type(psb_sspmat_type),intent(inout) :: l,u
type(psb_sspmat_type),intent(in), optional, target :: blck
real(psb_spk_), intent(inout) :: d(:)
end subroutine mld_silut_fact
end interface
character(len=15), parameter, private :: &
& fact_names(0:4)=(/'none ','DIAG ?? ',&
& 'ILU(n) ',&
& 'MILU(n) ','ILU(t,n) '/)
contains
subroutine s_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
type(psb_desc_type), intent(in) :: desc_data
class(mld_s_ilu_solver_type), intent(in) :: sv
real(psb_spk_),intent(in) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
integer :: n_row,n_col
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act
character :: trans_
character(len=20) :: name='d_ilu_solver_apply'
call psb_erractionsave(err_act)
info = psb_success_
trans_ = psb_toupper(trans)
select case(trans_)
case('N')
case('T','C')
case default
call psb_errpush(psb_err_iarg_invalid_i_,name)
goto 9999
end select
n_row = psb_cd_get_local_rows(desc_data)
n_col = psb_cd_get_local_cols(desc_data)
if (n_col <= size(work)) then
ww => work(1:n_col)
if ((4*n_col+n_col) <= size(work)) then
aux => work(n_col+1:)
else
allocate(aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/4*n_col,0,0,0,0/),&
& a_err='real(psb_spk_)')
goto 9999
end if
endif
else
allocate(ww(n_col),aux(4*n_col),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/5*n_col,0,0,0,0/),&
& a_err='real(psb_spk_)')
goto 9999
end if
endif
select case(trans_)
case('N')
call psb_spsm(sone,sv%l,x,szero,ww,desc_data,info,&
& trans=trans_,scale='L',diag=sv%d,choice=psb_none_,work=aux)
if (info == psb_success_) call psb_spsm(alpha,sv%u,ww,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_, work=aux)
case('T','C')
call psb_spsm(sone,sv%u,x,szero,ww,desc_data,info,&
& trans=trans_,scale='L',diag=sv%d,choice=psb_none_,work=aux)
if (info == psb_success_) call psb_spsm(alpha,sv%l,ww,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid TRANS in ILU subsolve')
goto 9999
end select
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Error in subsolve')
goto 9999
endif
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else
deallocate(aux)
endif
else
deallocate(ww,aux)
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_ilu_solver_apply
subroutine s_ilu_solver_bld(a,desc_a,sv,upd,info,b)
use psb_sparse_mod
Implicit None
! Arguments
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(mld_s_ilu_solver_type), intent(inout) :: sv
character, intent(in) :: upd
integer, intent(out) :: info
type(psb_sspmat_type), intent(in), target, optional :: b
! Local variables
integer :: n_row,n_col, nrow_a, nztota
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, debug_unit, debug_level
character(len=20) :: name='d_ilu_solver_bld', ch_err
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' start'
n_row = psb_cd_get_local_rows(desc_a)
if (psb_toupper(upd) == 'F') then
nrow_a = a%get_nrows()
nztota = a%get_nzeros()
if (present(b)) then
nztota = nztota + b%get_nzeros()
end if
call sv%l%csall(n_row,n_row,info,nztota)
if (info == psb_success_) call sv%u%csall(n_row,n_row,info,nztota)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (allocated(sv%d)) then
if (size(sv%d) < n_row) then
deallocate(sv%d)
endif
endif
if (.not.allocated(sv%d)) then
allocate(sv%d(n_row),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
endif
select case(sv%fact_type)
case (mld_ilu_t_)
!
! ILU(k,t)
!
select case(sv%fill_in)
case(:-1)
! Error: fill-in <= -1
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,sv%fill_in,0,0,0/))
goto 9999
case(0:)
! Fill-in >= 0
call mld_ilut_fact(sv%fill_in,sv%thresh,&
& a, sv%l,sv%u,sv%d,info,blck=b)
end select
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_ilut_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(mld_ilu_n_,mld_milu_n_)
!
! ILU(k) and MILU(k)
!
select case(sv%fill_in)
case(:-1)
! Error: fill-in <= -1
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,sv%fill_in,0,0,0/))
goto 9999
case(0)
! Fill-in 0
! Separate implementation of ILU(0) for better performance.
! There seems to be a problem with the separate implementation of MILU(0),
! contained into mld_ilu0_fact. This must be investigated. For the time being,
! resort to the implementation of MILU(k) with k=0.
if (sv%fact_type == mld_ilu_n_) then
call mld_ilu0_fact(sv%fact_type,a,sv%l,sv%u,&
& sv%d,info,blck=b,upd=upd)
else
call mld_iluk_fact(sv%fill_in,sv%fact_type,&
& a,sv%l,sv%u,sv%d,info,blck=b)
endif
case(1:)
! Fill-in >= 1
! The same routine implements both ILU(k) and MILU(k)
call mld_iluk_fact(sv%fill_in,sv%fact_type,&
& a,sv%l,sv%u,sv%d,info,blck=b)
end select
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_iluk_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case default
! If we end up here, something was wrong up in the call chain.
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end select
else
! Here we should add checks for reuse of L and U.
! For the time being just throw an error.
info = 31
call psb_errpush(info, name, i_err=(/3,0,0,0,0/),a_err=upd)
goto 9999
!
! What is an update of a factorization??
! A first attempt could be to reuse EXACTLY the existing indices
! as if it was an ILU(0) (since, effectively, the sparsity pattern
! should not grow beyond what is already there).
!
call mld_ilu0_fact(sv%fact_type,a,&
& sv%l,sv%u,&
& sv%d,info,blck=b,upd=upd)
end if
call sv%l%set_asb()
call sv%l%trim()
call sv%u%set_asb()
call sv%u%trim()
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_ilu_solver_bld
subroutine s_ilu_solver_seti(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_ilu_solver_type), intent(inout) :: sv
integer, intent(in) :: what
integer, intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_ilu_solver_seti'
info = psb_success_
call psb_erractionsave(err_act)
select case(what)
case(mld_sub_solve_)
sv%fact_type = val
case(mld_sub_fillin_)
sv%fill_in = val
case default
!!$ write(0,*) name,': Error: invalid WHAT'
!!$ info = -2
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_ilu_solver_seti
subroutine s_ilu_solver_setc(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_ilu_solver_type), intent(inout) :: sv
integer, intent(in) :: what
character(len=*), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act, ival
character(len=20) :: name='d_ilu_solver_setc'
info = psb_success_
call psb_erractionsave(err_act)
call mld_stringval(val,ival,info)
if (info == psb_success_) call sv%set(what,ival,info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info, name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_ilu_solver_setc
subroutine s_ilu_solver_setr(sv,what,val,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_ilu_solver_type), intent(inout) :: sv
integer, intent(in) :: what
real(psb_spk_), intent(in) :: val
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_ilu_solver_setr'
call psb_erractionsave(err_act)
info = psb_success_
select case(what)
case(mld_sub_iluthrs_)
sv%thresh = val
case default
!!$ write(0,*) name,': Error: invalid WHAT'
!!$ info = -2
!!$ goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_ilu_solver_setr
subroutine s_ilu_solver_free(sv,info)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_ilu_solver_type), intent(inout) :: sv
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='d_ilu_solver_free'
call psb_erractionsave(err_act)
info = psb_success_
if (allocated(sv%d)) then
deallocate(sv%d,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
end if
call sv%l%free()
call sv%u%free()
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_ilu_solver_free
subroutine s_ilu_solver_descr(sv,info,iout)
use psb_sparse_mod
Implicit None
! Arguments
class(mld_s_ilu_solver_type), intent(in) :: sv
integer, intent(out) :: info
integer, intent(in), optional :: iout
! Local variables
integer :: err_act
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_s_ilu_solver_descr'
integer :: iout_
call psb_erractionsave(err_act)
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = 6
endif
write(iout_,*) ' Incomplete factorization solver: ',&
& fact_names(sv%fact_type)
select case(sv%fact_type)
case(mld_ilu_n_,mld_milu_n_)
write(iout_,*) ' Fill level:',sv%fill_in
case(mld_ilu_t_)
write(iout_,*) ' Fill level:',sv%fill_in
write(iout_,*) ' Fill threshold :',sv%thresh
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine s_ilu_solver_descr
function s_ilu_solver_sizeof(sv) result(val)
use psb_sparse_mod
implicit none
! Arguments
class(mld_s_ilu_solver_type), intent(in) :: sv
integer(psb_long_int_k_) :: val
integer :: i
val = 2*psb_sizeof_int + psb_sizeof_sp
if (allocated(sv%d)) val = val + psb_sizeof_sp * size(sv%d)
val = val + psb_sizeof(sv%l)
val = val + psb_sizeof(sv%u)
return
end function s_ilu_solver_sizeof
end module mld_s_ilu_solver

1406
mlprec/mld_s_prec_type.f03
View File

File diff suppressed because it is too large Load Diff

702
mlprec/mld_s_prec_type.f90
Unescape Escape View File

@ -1,702 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_prec_type.f90
!
! Module: mld_prec_type
!
! This module defines:
! - the mld_prec_type data structure containing the preconditioner and related
! data structures;
! - integer constants defining the preconditioner;
! - character constants describing the preconditioner (used by the routines
! printing out a preconditioner description);
! - the interfaces to the routines for the management of the preconditioner
! data structure (see below).
!
! It contains routines for
! - converting character constants defining the preconditioner into integer
! constants;
! - checking if the preconditioner is correctly defined;
! - printing a description of the preconditioner;
! - deallocating the preconditioner data structure.
!
module mld_s_prec_type
use mld_base_prec_type
!
! Type: mld_Tprec_type.
!
! It is the data type containing all the information about the multilevel
! preconditioner (here and in the following 'T' denotes 'd', 's', 'c' and
! 'z', according to the real/complex, single/double precision version of
! MLD2P4). It consists of an array of 'one-level' intermediate data structures
! of type mld_Tonelev_type, each containing the information needed to apply
! the smoothing and the coarse-space correction at a generic level.
!
! type mld_Tprec_type
! type(mld_Tonelev_type), allocatable :: precv(:)
! end type mld_Tprec_type
!
! Note that the levels are numbered in increasing order starting from
! the finest one and the number of levels is given by size(precv(:)).
!
!
! Type: mld_Tonelev_type.
!
! It is the data type containing the necessary items for the current
! level (essentially, the base preconditioner, the current-level matrix
! and the restriction and prolongation operators).
!
! type mld_Tonelev_type
! type(mld_Tbaseprec_type) :: prec
! integer, allocatable :: iprcparm(:)
! real(psb_Tpk_), allocatable :: rprcparm(:)
! type(psb_Tspmat_type) :: ac
! type(psb_desc_type) :: desc_ac
! type(psb_Tspmat_type), pointer :: base_a => null()
! type(psb_desc_type), pointer :: base_desc => null()
! type(psb_Tlinmap_type) :: map
! end type mld_Tonelev_type
!
! Note that psb_Tpk denotes the kind of the real data type to be chosen
! according to single/double precision version of MLD2P4.
!
! prec - type(mld_Tbaseprec_type).
! The current level preconditioner (aka smoother).
! iprcparm - integer, dimension(:), allocatable.
! The integer parameters defining the multilevel strategy.
! rprcparm - real(psb_Ypk_), dimension(:), allocatable.
! The real parameters defining the multilevel strategy.
! ac - The local part of the current-level matrix, built by
! coarsening the previous-level matrix.
! desc_ac - type(psb_desc_type).
! The communication descriptor associated to the matrix
! stored in ac.
! base_a - type(psb_zspmat_type), pointer.
! Pointer (really a pointer!) to the local part of the current
! matrix (so we have a unified treatment of residuals).
! We need this to avoid passing explicitly the current matrix
! to the routine which applies the preconditioner.
! base_desc - type(psb_desc_type), pointer.
! Pointer to the communication descriptor associated to the
! matrix pointed by base_a.
! map - Stores the maps (restriction and prolongation) between the
! vector spaces associated to the index spaces of the previous
! and current levels.
!
!
! Type: mld_Tbaseprec_type.
!
! It holds the smoother (base preconditioner) at a single level.
!
! type mld_Tbaseprec_type
! type(psb_Tspmat_type), allocatable :: av(:)
! IntrType(psb_Tpk_), allocatable :: d(:)
! type(psb_desc_type) :: desc_data
! integer, allocatable :: iprcparm(:)
! real(psb_Tpk_), allocatable :: rprcparm(:)
! integer, allocatable :: perm(:), invperm(:)
! end type mld_sbaseprec_type
!
! Note that IntrType denotes the real or complex data type, and psb_Tpk denotes
! the kind of the real or complex type, according to the real/complex, single/double
! precision version of MLD2P4.
!
! av - type(psb_Tspmat_type), dimension(:), allocatable(:).
! The sparse matrices needed to apply the preconditioner at
! the current level ilev.
! av(mld_l_pr_) - The L factor of the ILU factorization of the local
! diagonal block of the current-level matrix A(ilev).
! av(mld_u_pr_) - The U factor of the ILU factorization of the local
! diagonal block of A(ilev), except its diagonal entries
! (stored in d).
! av(mld_ap_nd_) - The entries of the local part of A(ilev) outside
! the diagonal block, for block-Jacobi sweeps.
! d - real/complex(psb_Tpk_), dimension(:), allocatable.
! The diagonal entries of the U factor in the ILU factorization
! of A(ilev).
! desc_data - type(psb_desc_type).
! The communication descriptor associated to the base preconditioner,
! i.e. to the sparse matrices needed to apply the base preconditioner
! at the current level.
! iprcparm - integer, dimension(:), allocatable.
! The integer parameters defining the base preconditioner K(ilev)
! (the iprcparm entries and values are specified below).
! rprcparm - real(psb_Tpk_), dimension(:), allocatable.
! The real parameters defining the base preconditioner K(ilev)
! (the rprcparm entries and values are specified below).
! perm - integer, dimension(:), allocatable.
! The row and column permutations applied to the local part of
! A(ilev) (defined only if iprcparm(mld_sub_ren_)>0).
! invperm - integer, dimension(:), allocatable.
! The inverse of the permutation stored in perm.
!
! Note that when the LU factorization of the (local part of the) matrix A(ilev) is
! computed instead of the ILU one, by using UMFPACK, SuperLU or SuperLU_dist, the
! corresponding L and U factors are stored in data structures provided by those
! packages and pointed by prec%iprcparm(mld_umf_ptr), prec%iprcparm(mld_slu_ptr)
! or prec%iprcparm(mld_slud_ptr).
!
type mld_sbaseprec_type
type(psb_sspmat_type), allocatable :: av(:)
real(psb_spk_), allocatable :: d(:)
type(psb_desc_type) :: desc_data
integer, allocatable :: iprcparm(:)
real(psb_spk_), allocatable :: rprcparm(:)
integer, allocatable :: perm(:), invperm(:)
end type mld_sbaseprec_type
type mld_sonelev_type
type(mld_sbaseprec_type) :: prec
integer, allocatable :: iprcparm(:)
real(psb_spk_), allocatable :: rprcparm(:)
type(psb_sspmat_type) :: ac
type(psb_desc_type) :: desc_ac
type(psb_sspmat_type), pointer :: base_a => null()
type(psb_desc_type), pointer :: base_desc => null()
type(psb_slinmap_type) :: map
end type mld_sonelev_type
type, extends(psb_sprec_type) :: mld_sprec_type
type(mld_sonelev_type), allocatable :: precv(:)
contains
procedure, pass(prec) :: s_apply2v => mld_s_apply2v
procedure, pass(prec) :: s_apply1v => mld_s_apply1v
end type mld_sprec_type
!
! Interfaces to routines for checking the definition of the preconditioner,
! for printing its description and for deallocating its data structure
!
interface mld_precfree
module procedure mld_sbase_precfree, mld_s_onelev_precfree, mld_sprec_free
end interface
interface mld_nullify_baseprec
module procedure mld_nullify_sbaseprec
end interface
interface mld_nullify_onelevprec
module procedure mld_nullify_s_onelevprec
end interface
interface mld_precdescr
module procedure mld_sfile_prec_descr
end interface
interface mld_sizeof
module procedure mld_sprec_sizeof, mld_sbaseprec_sizeof, mld_s_onelev_prec_sizeof
end interface
interface mld_precaply
subroutine mld_sprecaply(prec,x,y,desc_data,info,trans,work)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
import mld_sprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_sprec_type), intent(in) :: prec
real(psb_spk_),intent(in) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
integer, intent(out) :: info
character(len=1), optional :: trans
real(psb_spk_),intent(inout), optional, target :: work(:)
end subroutine mld_sprecaply
subroutine mld_sprecaply1(prec,x,desc_data,info,trans)
use psb_sparse_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
import mld_sprec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_sprec_type), intent(in) :: prec
real(psb_spk_),intent(inout) :: x(:)
integer, intent(out) :: info
character(len=1), optional :: trans
end subroutine mld_sprecaply1
end interface
contains
!
! Function returning the size of the mld_prec_type data structure
!
function mld_sprec_sizeof(prec) result(val)
implicit none
type(mld_sprec_type), intent(in) :: prec
integer(psb_long_int_k_) :: val
integer :: i
val = 0
if (allocated(prec%precv)) then
do i=1, size(prec%precv)
val = val + mld_sizeof(prec%precv(i))
end do
end if
end function mld_sprec_sizeof
function mld_sbaseprec_sizeof(prec) result(val)
implicit none
type(mld_sbaseprec_type), intent(in) :: prec
integer(psb_long_int_k_) :: val
integer :: i
val = 0
if (allocated(prec%iprcparm)) then
val = val + psb_sizeof_int * size(prec%iprcparm)
if (prec%iprcparm(mld_prec_status_) == mld_prec_built_) then
select case(prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_ilu_t_)
! do nothing
case(mld_slu_)
case(mld_umf_)
case(mld_sludist_)
case default
end select
end if
end if
if (allocated(prec%rprcparm)) val = val + psb_sizeof_sp * size(prec%rprcparm)
if (allocated(prec%d)) val = val + psb_sizeof_sp * size(prec%d)
if (allocated(prec%perm)) val = val + psb_sizeof_int * size(prec%perm)
if (allocated(prec%invperm)) val = val + psb_sizeof_int * size(prec%invperm)
val = val + psb_sizeof(prec%desc_data)
if (allocated(prec%av)) then
do i=1,size(prec%av)
val = val + psb_sizeof(prec%av(i))
end do
end if
end function mld_sbaseprec_sizeof
function mld_s_onelev_prec_sizeof(prec) result(val)
implicit none
type(mld_sonelev_type), intent(in) :: prec
integer(psb_long_int_k_) :: val
integer :: i
val = mld_sizeof(prec%prec)
if (allocated(prec%iprcparm)) then
val = val + psb_sizeof_int * size(prec%iprcparm)
end if
if (allocated(prec%rprcparm)) val = val + psb_sizeof_sp * size(prec%rprcparm)
val = val + psb_sizeof(prec%desc_ac)
val = val + psb_sizeof(prec%ac)
val = val + psb_sizeof(prec%map)
end function mld_s_onelev_prec_sizeof
!
! Subroutine: mld_file_prec_descr
! Version: real
!
! This routine prints a description of the preconditioner to the standard
! output or to a file. It must be called after the preconditioner has been
! built by mld_precbld.
!
! Arguments:
! p - type(mld_Tprec_type), input.
! The preconditioner data structure to be printed out.
! info - integer, output.
! error code.
! iout - integer, input, optional.
! The id of the file where the preconditioner description
! will be printed. If iout is not present, then the standard
! output is condidered.
!
subroutine mld_sfile_prec_descr(p,info,iout)
implicit none
! Arguments
type(mld_sprec_type), intent(in) :: p
integer, intent(out) :: info
integer, intent(in), optional :: iout
! Local variables
integer :: ilev, nlev
integer :: ictxt, me, np
character(len=20), parameter :: name='mld_file_prec_descr'
integer :: iout_
info = psb_success_
if (present(iout)) then
iout_ = iout
else
iout_ = 6
end if
if (iout_ < 0) iout_ = 6
if (allocated(p%precv)) then
ictxt = psb_cd_get_context(p%precv(1)%prec%desc_data)
call psb_info(ictxt,me,np)
!
! The preconditioner description is printed by processor psb_root_.
! This agrees with the fact that all the parameters defining the
! preconditioner have the same values on all the procs (this is
! ensured by mld_precbld).
!
if (me == psb_root_) then
write(iout_,*)
write(iout_,*) 'Preconditioner description'
nlev = size(p%precv)
if (nlev >= 1) then
!
! Print description of base preconditioner
!
write(iout_,*) ' '
if (nlev > 1) then
write(iout_,*) 'Multilevel Schwarz'
write(iout_,*)
write(iout_,*) 'Base preconditioner (smoother) details'
endif
ilev = 1
call mld_base_prec_descr(iout_,p%precv(ilev)%prec%iprcparm,info,&
& rprcparm=p%precv(ilev)%prec%rprcparm)
end if
if (nlev > 1) then
!
! Print multilevel details
!
write(iout_,*)
write(iout_,*) 'Multilevel details'
do ilev = 2, nlev
if (.not.allocated(p%precv(ilev)%iprcparm)) then
info = 3111
write(iout_,*) ' ',name,': error: inconsistent MLPREC part, should call MLD_PRECINIT'
return
endif
end do
write(iout_,*) ' Number of levels: ',nlev
!
! Currently, all the preconditioner parameters must have the same value at levels
! 2,...,nlev-1, hence only the values at level 2 are printed
!
ilev=2
call mld_ml_alg_descr(iout_,ilev,p%precv(ilev)%iprcparm, info,&
& rprcparm=p%precv(ilev)%rprcparm)
!
! Coarse matrices are different at levels 2,...,nlev-1, hence related
! info is printed separately
!
write(iout_,*)
do ilev = 2, nlev-1
call mld_ml_level_descr(iout_,ilev,p%precv(ilev)%iprcparm,&
& p%precv(ilev)%map%naggr,info,&
& rprcparm=p%precv(ilev)%rprcparm)
end do
!
! Print coarsest level details
!
ilev = nlev
write(iout_,*)
call mld_ml_coarse_descr(iout_,ilev,&
& p%precv(ilev)%iprcparm,p%precv(ilev)%prec%iprcparm,&
& p%precv(ilev)%map%naggr,info,&
& rprcparm=p%precv(ilev)%rprcparm, &
& rprcparm2=p%precv(ilev)%prec%rprcparm)
end if
endif
write(iout_,*)
else
write(iout_,*) trim(name), &
& ': Error: no base preconditioner available, something is wrong!'
info = -2
return
endif
end subroutine mld_sfile_prec_descr
!
! Subroutines: mld_Tbase_precfree, mld_T_onelev_precfree, mld_Tprec_free
! Version: real/complex
!
! These routines deallocate the mld_Tbaseprec_type, mld_Tonelev_type and
! mld_Tprec_type data structures.
!
! Arguments:
! p - type(mld_Tbaseprec_type/mld_Tonelev_type/mld_Tprec_type), input.
! The data structure to be deallocated.
! info - integer, output.
! error code.
!
subroutine mld_sbase_precfree(p,info)
implicit none
type(mld_sbaseprec_type), intent(inout) :: p
integer, intent(out) :: info
integer :: i
info = psb_success_
! Actually we might just deallocate the top level array, except
! for the inner UMFPACK or SLU stuff
if (allocated(p%d)) then
deallocate(p%d,stat=info)
end if
if (allocated(p%av)) then
do i=1,size(p%av)
call p%av(i)%free()
if (info /= psb_success_) then
! Actually, we don't care here about this.
! Just let it go.
! return
end if
enddo
deallocate(p%av,stat=info)
end if
if (allocated(p%desc_data%matrix_data)) &
& call psb_cdfree(p%desc_data,info)
if (allocated(p%rprcparm)) then
deallocate(p%rprcparm,stat=info)
end if
if (allocated(p%perm)) then
deallocate(p%perm,stat=info)
endif
if (allocated(p%invperm)) then
deallocate(p%invperm,stat=info)
endif
if (allocated(p%iprcparm)) then
if (p%iprcparm(mld_prec_status_) == mld_prec_built_) then
if (p%iprcparm(mld_sub_solve_) == mld_slu_) then
call mld_sslu_free(p%iprcparm(mld_slu_ptr_),info)
end if
end if
deallocate(p%iprcparm,stat=info)
end if
call mld_nullify_baseprec(p)
end subroutine mld_sbase_precfree
subroutine mld_s_onelev_precfree(p,info)
implicit none
type(mld_sonelev_type), intent(inout) :: p
integer, intent(out) :: info
integer :: i
info = psb_success_
! Actually we might just deallocate the top level array, except
! for the inner UMFPACK or SLU stuff
call mld_precfree(p%prec,info)
call p%ac%free()
if (allocated(p%desc_ac%matrix_data)) &
& call psb_cdfree(p%desc_ac,info)
if (allocated(p%rprcparm)) then
deallocate(p%rprcparm,stat=info)
end if
! This is a pointer to something else, must not free it here.
nullify(p%base_a)
! This is a pointer to something else, must not free it here.
nullify(p%base_desc)
!
! free explicitly map???
! For now thanks to allocatable semantics
! works anyway.
!
call mld_nullify_onelevprec(p)
end subroutine mld_s_onelev_precfree
subroutine mld_nullify_s_onelevprec(p)
implicit none
type(mld_sonelev_type), intent(inout) :: p
nullify(p%base_a)
nullify(p%base_desc)
end subroutine mld_nullify_s_onelevprec
subroutine mld_nullify_sbaseprec(p)
implicit none
type(mld_sbaseprec_type), intent(inout) :: p
end subroutine mld_nullify_sbaseprec
subroutine mld_sprec_free(p,info)
use psb_sparse_mod
implicit none
! Arguments
type(mld_sprec_type), intent(inout) :: p
integer, intent(out) :: info
! Local variables
integer :: me,err_act,i
character(len=20) :: name
if(psb_get_errstatus().ne.0) return
info=psb_success_
name = 'mld_dprecfree'
call psb_erractionsave(err_act)
me=-1
if (allocated(p%precv)) then
do i=1,size(p%precv)
call mld_precfree(p%precv(i),info)
end do
deallocate(p%precv)
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_sprec_free
subroutine mld_s_apply2v(prec,x,y,desc_data,info,trans,work)
use psb_sparse_mod
type(psb_desc_type),intent(in) :: desc_data
class(mld_sprec_type), intent(in) :: prec
real(psb_spk_),intent(in) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
integer, intent(out) :: info
character(len=1), optional :: trans
real(psb_spk_),intent(inout), optional, target :: work(:)
Integer :: err_act
character(len=20) :: name='s_prec_apply'
call psb_erractionsave(err_act)
select type(prec)
type is (mld_sprec_type)
!!$ call mld_precaply(prec,x,y,desc_data,info,trans,work)
class default
info = 700
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_s_apply2v
subroutine mld_s_apply1v(prec,x,desc_data,info,trans)
use psb_sparse_mod
type(psb_desc_type),intent(in) :: desc_data
class(mld_sprec_type), intent(in) :: prec
real(psb_spk_),intent(inout) :: x(:)
integer, intent(out) :: info
character(len=1), optional :: trans
Integer :: err_act
character(len=20) :: name='s_prec_apply'
call psb_erractionsave(err_act)
select type(prec)
type is (mld_sprec_type)
!!$ call mld_precaply(prec,x,desc_data,info,trans)
class default
info = 700
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_s_apply1v
end module mld_s_prec_type

36
mlprec/mld_saggrmap_bld.f90
Unescape Escape View File

@ -121,19 +121,20 @@ subroutine mld_saggrmap_bld(aggr_type,theta,a,desc_a,ilaggr,nlaggr,info)
call mld_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info) call mld_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info)
case (mld_sym_dec_aggr_) case (mld_sym_dec_aggr_)
nr = psb_sp_get_nrows(a) nr = a%get_nrows()
call psb_sp_clip(a,atmp,info,imax=nr,jmax=nr,& call a%csclip(atmp,info,imax=nr,jmax=nr,&
& rscale=.false.,cscale=.false.) & rscale=.false.,cscale=.false.)
atmp%m=nr call atmp%set_nrows(nr)
atmp%k=nr call atmp%set_ncols(nr)
if (info == psb_success_) call psb_transp(atmp,atrans,fmt='COO') if (info == psb_success_) call atrans%transp(atmp)
if (info == psb_success_) call atrans%cscnv(info,type='COO')
if (info == psb_success_) call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.) if (info == psb_success_) call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.)
atmp%m=nr call atmp%set_nrows(nr)
atmp%k=nr call atmp%set_ncols(nr)
if (info == psb_success_) call psb_sp_free(atrans,info) if (info == psb_success_) call atrans%free()
if (info == psb_success_) call psb_spcnv(atmp,info,afmt='csr') if (info == psb_success_) call atmp%cscnv(info,type='CSR')
if (info == psb_success_) call mld_dec_map_bld(theta,atmp,desc_a,nlaggr,ilaggr,info) if (info == psb_success_) call mld_dec_map_bld(theta,atmp,desc_a,nlaggr,ilaggr,info)
if (info == psb_success_) call psb_sp_free(atmp,info) if (info == psb_success_) call atmp%free()
case default case default
@ -198,7 +199,7 @@ contains
nrow = psb_cd_get_local_rows(desc_a) nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a) ncol = psb_cd_get_local_cols(desc_a)
nr = a%m nr = a%get_nrows()
allocate(ilaggr(nr),neigh(nr),stat=info) allocate(ilaggr(nr),neigh(nr),stat=info)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
@ -214,7 +215,7 @@ contains
& a_err='real(psb_spk_)') & a_err='real(psb_spk_)')
goto 9999 goto 9999
end if end if
call psb_sp_getdiag(a,diag,info) call a%get_diag(diag,info)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_sp_getdiag') call psb_errpush(info,name,a_err='psb_sp_getdiag')
@ -247,10 +248,10 @@ contains
naggr = naggr + 1 naggr = naggr + 1
ilaggr(i) = naggr ilaggr(i) = naggr
call psb_sp_getrow(i,a,nz,irow,icol,val,info) call a%csget(i,i,nz,irow,icol,val,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_sp_getrow') call psb_errpush(info,name,a_err='csget')
goto 9999 goto 9999
end if end if
@ -268,7 +269,7 @@ contains
! !
! 2. Untouched neighbours of these nodes are marked <0. ! 2. Untouched neighbours of these nodes are marked <0.
! !
call psb_neigh(a,i,neigh,n_ne,info,lev=2) call a%get_neigh(i,neigh,n_ne,info,lev=2)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_neigh') call psb_errpush(info,name,a_err='psb_neigh')
@ -288,8 +289,7 @@ contains
enddo enddo
if (debug_level >= psb_debug_outer_) then if (debug_level >= psb_debug_outer_) then
write(debug_unit,*) me,' ',trim(name),& write(debug_unit,*) me,' ',trim(name),&
& ' Check 1:',count(ilaggr == -(nr+1)),& & ' Check 1:',count(ilaggr == -(nr+1))
& (a%ia1(i),i=a%ia2(1),a%ia2(2)-1)
end if end if
! !
@ -336,7 +336,7 @@ contains
isz = nr+1 isz = nr+1
ia = -1 ia = -1
cpling = szero cpling = szero
call psb_sp_getrow(i,a,nz,irow,icol,val,info) call a%csget(i,i,nz,irow,icol,val,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_sp_getrow') call psb_errpush(info,name,a_err='psb_sp_getrow')

122
mlprec/mld_saggrmat_nosmth_asb.F90
Unescape Escape View File

@ -100,12 +100,13 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
type(mld_sonelev_type), intent(inout), target :: p type(mld_sonelev_type), intent(inout), target :: p
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
integer ::ictxt,np,me, err_act, icomm integer ::ictxt,np,me, err_act, icomm
character(len=20) :: name character(len=20) :: name
type(psb_sspmat_type) :: b type(psb_sspmat_type) :: b
integer, allocatable :: nzbr(:), idisp(:) integer, allocatable :: nzbr(:), idisp(:)
type(psb_sspmat_type) :: am1,am2 type(psb_sspmat_type) :: am1,am2
type(psb_s_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzt, naggrm1, i & naggr, nzt, naggrm1, i
@ -114,7 +115,6 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
info=psb_success_ info=psb_success_
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
call psb_nullify_sp(b)
ictxt = psb_cd_get_context(desc_a) ictxt = psb_cd_get_context(desc_a)
icomm = psb_cd_get_mpic(desc_a) icomm = psb_cd_get_mpic(desc_a)
@ -123,9 +123,6 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
nrow = psb_cd_get_local_rows(desc_a) nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a) ncol = psb_cd_get_local_cols(desc_a)
call psb_nullify_sp(am1)
call psb_nullify_sp(am2)
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
@ -152,47 +149,36 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then
call psb_sp_all(ncol,ntaggr,am1,ncol,info) call acoo1%allocate(ncol,ntaggr,ncol)
else else
call psb_sp_all(ncol,naggr,am1,ncol,info) call acoo1%allocate(ncol,naggr,ncol)
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spall')
goto 9999
end if end if
do i=1,nrow do i=1,nrow
am1%aspk(i) = sone acoo1%val(i) = done
am1%ia1(i) = i acoo1%ia(i) = i
am1%ia2(i) = ilaggr(i) acoo1%ja(i) = ilaggr(i)
end do end do
am1%infoa(psb_nnz_) = nrow
call psb_spcnv(am1,info,afmt='csr',dupl=psb_dupl_add_) call acoo1%set_dupl(psb_dupl_add_)
call psb_transp(am1,am2) call acoo1%set_nzeros(nrow)
call acoo1%set_asb()
call acoo1%fix(info)
call acoo2%transp(acoo1)
call a%csclip(bcoo,info,jmax=nrow)
call psb_sp_clip(a,b,info,jmax=nrow)
if(info /= psb_success_) then nzt = bcoo%get_nzeros()
call psb_errpush(psb_err_from_subroutine_,name,a_err='spclip')
goto 9999
end if
! Out from sp_clip is always in COO, but just in case..
if (psb_tolower(b%fida) /= 'coo') then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spclip NOT COO')
goto 9999
end if
nzt = psb_sp_get_nnzeros(b)
do i=1, nzt do i=1, nzt
b%ia1(i) = ilaggr(b%ia1(i)) bcoo%ia(i) = ilaggr(bcoo%ia(i))
b%ia2(i) = ilaggr(b%ia2(i)) bcoo%ja(i) = ilaggr(bcoo%ja(i))
enddo enddo
b%m = naggr call bcoo%set_nrows(naggr)
b%k = naggr call bcoo%set_ncols(naggr)
! This is to minimize data exchange call bcoo%set_dupl(psb_dupl_add_)
call psb_spcnv(b,info,afmt='coo',dupl=psb_dupl_add_) call bcoo%fix(info)
if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then
@ -206,81 +192,73 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
nzbr(me+1) = nzt nzbr(me+1) = nzt
call psb_sum(ictxt,nzbr(1:np)) call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr) nzac = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info) call ac_coo%allocate(ntaggr,ntaggr,nzac)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_all')
goto 9999
end if
do ip=1,np do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
enddo enddo
ndx = nzbr(me+1) ndx = nzbr(me+1)
call mpi_allgatherv(b%aspk,ndx,mpi_real,p%ac%aspk,nzbr,idisp,& call mpi_allgatherv(bcoo%val,ndx,mpi_double_precision,ac_coo%val,nzbr,idisp,&
& mpi_real,icomm,info) & mpi_real,icomm,info)
call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,& call mpi_allgatherv(bcoo%ia,ndx,mpi_integer,ac_coo%ia,nzbr,idisp,&
& mpi_integer,icomm,info) & mpi_integer,icomm,info)
call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,& call mpi_allgatherv(bcoo%ja,ndx,mpi_integer,ac_coo%ja,nzbr,idisp,&
& mpi_integer,icomm,info) & mpi_integer,icomm,info)
if(info /= psb_success_) then if(info /= psb_success_) then
info=-1 info=-1
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
call ac_coo%set_nzeros(nzac)
p%ac%m = ntaggr call ac_coo%set_dupl(psb_dupl_add_)
p%ac%k = ntaggr call ac_coo%fix(info)
p%ac%infoa(psb_nnz_) = nzac call p%ac%mv_from(ac_coo)
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_free')
goto 9999
end if
else if (p%iprcparm(mld_coarse_mat_) == mld_distr_mat_) then else if (p%iprcparm(mld_coarse_mat_) == mld_distr_mat_) then
call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info) if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_sp_clone(b,p%ac,info) call p%ac%mv_from(bcoo)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build ac, desc_ac') call psb_errpush(psb_err_internal_error_,name,a_err='Build ac, desc_ac')
goto 9999 goto 9999
end if
call psb_sp_free(b,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_free')
goto 9999
end if
end if
else else
info = psb_err_internal_error_ info = psb_err_internal_error_
call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_') call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_')
goto 9999 goto 9999
end if end if
call bcoo%free()
deallocate(nzbr,idisp) deallocate(nzbr,idisp)
call psb_spcnv(p%ac,info,afmt='csr',dupl=psb_dupl_add_) call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') call psb_errpush(psb_err_from_subroutine_,name,a_err='cscnv')
goto 9999 goto 9999
end if end if
call am1%mv_from(acoo1)
call am1%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call am2%mv_from(acoo2)
if (info == psb_success_) call am2%cscnv(info,type='csr',dupl=psb_dupl_add_)
! !
! Copy the prolongation/restriction matrices into the descriptor map. ! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => PR^T i.e. restriction operator ! am2 => PR^T i.e. restriction operator
! am1 => PR i.e. prolongation operator ! am1 => PR i.e. prolongation operator
! !
p%map = psb_linmap(psb_map_aggr_,desc_a,& if (info == psb_success_) &
& p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1,ilaggr,nlaggr) & p%desc_ac,am2,am1,ilaggr,nlaggr)
if (info == psb_success_) call psb_sp_free(am1,info) if (info == psb_success_) call am1%free()
if (info == psb_success_) call psb_sp_free(am2,info) if (info == psb_success_) call am2%free()
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build')
goto 9999 goto 9999
end if end if

400
mlprec/mld_saggrmat_smth_asb.F90
Unescape Escape View File

@ -121,11 +121,12 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
type(psb_sspmat_type) :: b type(psb_sspmat_type) :: b
integer, allocatable :: nzbr(:), idisp(:) integer, allocatable :: nzbr(:), idisp(:)
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer ::ictxt,np,me, err_act, icomm integer ::ictxt,np,me, err_act, icomm
character(len=20) :: name character(len=20) :: name
type(psb_sspmat_type) :: am1,am2, af type(psb_sspmat_type) :: am1,am2, am3, am4
type(psb_sspmat_type) :: am3,am4 type(psb_s_coo_sparse_mat) :: acoo1, acoo2, acoof, acoo3,acoo4, bcoo, cootmp
type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsrf, acsr3,acsr4, bcsr
real(psb_spk_), allocatable :: adiag(:) real(psb_spk_), allocatable :: adiag(:)
logical :: ml_global_nmb, filter_mat logical :: ml_global_nmb, filter_mat
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
@ -145,14 +146,6 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
call psb_nullify_sp(b)
call psb_nullify_sp(am3)
call psb_nullify_sp(am4)
call psb_nullify_sp(am1)
call psb_nullify_sp(am2)
call psb_nullify_sp(AF)
nglob = psb_cd_get_global_rows(desc_a) nglob = psb_cd_get_global_rows(desc_a)
nrow = psb_cd_get_local_rows(desc_a) nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a) ncol = psb_cd_get_local_cols(desc_a)
@ -201,7 +194,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
! Get the diagonal D ! Get the diagonal D
call psb_sp_getdiag(a,adiag,info) call a%get_diag(adiag,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info) & call psb_halo(adiag,desc_a,info)
@ -211,85 +204,69 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
am4%fida='COO'
am4%m=ncol
if (ml_global_nmb) then
am4%k=ntaggr
call psb_sp_all(ncol,ntaggr,am4,ncol,info)
else
am4%k=naggr
call psb_sp_all(ncol,naggr,am4,ncol,info)
endif
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spall')
goto 9999
end if
if (ml_global_nmb) then if (ml_global_nmb) then
call acoo4%allocate(ncol,ntaggr,ncol)
do i=1,ncol do i=1,ncol
am4%aspk(i) = sone acoo4%val(i) = done
am4%ia1(i) = i acoo4%ia(i) = i
am4%ia2(i) = ilaggr(i) acoo4%ja(i) = ilaggr(i)
end do end do
am4%infoa(psb_nnz_) = ncol call acoo4%set_nzeros(ncol)
else else
call acoo4%allocate(ncol,naggr,ncol)
do i=1,nrow do i=1,nrow
am4%aspk(i) = sone acoo4%val(i) = done
am4%ia1(i) = i acoo4%ia(i) = i
am4%ia2(i) = ilaggr(i) acoo4%ja(i) = ilaggr(i)
end do end do
am4%infoa(psb_nnz_) = nrow call acoo4%set_nzeros(nrow)
endif endif
call acoo4%set_dupl(psb_dupl_add_)
call acsr4%mv_from_coo(acoo4,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
call psb_spcnv(am4,info,afmt='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call psb_spcnv(a,am3,info,afmt='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' Initial copies done.' & ' Initial copies done.'
if (filter_mat) then if (filter_mat) then
! !
! Build the filtered matrix Af from A ! Build the filtered matrix Af from A
! !
call psb_spcnv(a,af,info,afmt='csr',dupl=psb_dupl_add_) if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_)
do i=1,nrow do i=1,nrow
tmp = szero tmp = szero
jd = -1 jd = -1
do j=af%ia2(i),af%ia2(i+1)-1 do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (af%ia1(j) == i) jd = j if (acsrf%ja(j) == i) jd = j
if (abs(af%aspk(j)) < theta*sqrt(abs(adiag(i)*adiag(af%ia1(j))))) then if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
tmp=tmp+af%aspk(j) tmp=tmp+acsrf%val(j)
af%aspk(j)=szero acsrf%val(j)=szero
endif endif
enddo enddo
if (jd == -1) then if (jd == -1) then
write(0,*) 'Wrong input: we need the diagonal!!!!', i write(0,*) 'Wrong input: we need the diagonal!!!!', i
else else
af%aspk(jd)=af%aspk(jd)-tmp acsrf%val(jd)=acsrf%val(jd)-tmp
end if end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call psb_spcnv(af,info,afmt='coo') call acsrf%mv_to_coo(acoof,info)
k = 0 k = 0
do j=1,psb_sp_get_nnzeros(af) do j=1,acoof%get_nzeros()
if ((af%aspk(j) /= szero) .or. (af%ia1(j) == af%ia2(j))) then if ((acoof%val(j) /= dzero) .or. (acoof%ia(j) == acoof%ja(j))) then
k = k + 1 k = k + 1
af%aspk(k) = af%aspk(j) acoof%val(k) = acoof%val(j)
af%ia1(k) = af%ia1(j) acoof%ia(k) = acoof%ia(j)
af%ia2(k) = af%ia2(j) acoof%ja(k) = acoof%ja(j)
end if end if
end do end do
!!$ write(debug_unit,*) me,' ',trim(name),' Non zeros from filtered matrix:',k,af%m,af%k call acoof%set_nzeros(k)
call psb_sp_setifld(k,psb_nnz_,af,info) call acoof%set_dupl(psb_dupl_add_)
call psb_spcnv(af,info,afmt='csr') call acsrf%mv_from_coo(acoof,info)
end if end if
@ -301,9 +278,8 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
end do end do
if (filter_mat) call psb_sp_scal(adiag,af,info) if (filter_mat) call acsrf%scal(adiag,info)
if (info == psb_success_) call acsr3%scal(adiag,info)
call psb_sp_scal(adiag,am3,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
@ -316,30 +292,25 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
! !
! This only works with CSR ! This only works with CSR
! !
if (psb_toupper(am3%fida) == 'CSR') then anorm = szero
anorm = szero dg = sone
dg = sone nrw = acsr3%get_nrows()
do i=1,am3%m do i=1, nrw
tmp = szero tmp = szero
do j=am3%ia2(i),am3%ia2(i+1)-1 do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (am3%ia1(j) <= am3%m) then if (acsr3%ja(j) <= nrw) then
tmp = tmp + abs(am3%aspk(j)) tmp = tmp + abs(acsr3%val(j))
endif endif
if (am3%ia1(j) == i ) then if (acsr3%ja(j) == i ) then
dg = abs(am3%aspk(j)) dg = abs(acsr3%val(j))
end if end if
end do end do
anorm = max(anorm,tmp/dg) anorm = max(anorm,tmp/dg)
enddo enddo
call psb_amx(ictxt,anorm) call psb_amx(ictxt,anorm)
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='this section only CSR')
goto 9999
endif
else else
anorm = psb_spnrmi(am3,desc_a,info) anorm = acsr3%csnmi()
endif endif
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format')
@ -368,20 +339,15 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
! !
! Build the smoothed prolongator using the filtered matrix ! Build the smoothed prolongator using the filtered matrix
! !
if (psb_toupper(af%fida) == 'CSR') then do i=1,acsrf%get_nrows()
do i=1,af%m do j=acsrf%irp(i),acsrf%irp(i+1)-1
do j=af%ia2(i),af%ia2(i+1)-1 if (acsrf%ja(j) == i) then
if (af%ia1(j) == i) then acsrf%val(j) = sone - omega*acsrf%val(j)
af%aspk(j) = sone - omega*af%aspk(j) else
else acsrf%val(j) = - omega*acsrf%val(j)
af%aspk(j) = - omega*af%aspk(j) end if
end if
end do
end do end do
else end do
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AF storage format')
goto 9999
end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
@ -389,39 +355,35 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
! !
! Symbmm90 does the allocation for its result. ! Symbmm90 does the allocation for its result.
! !
! am1 = (I-w*D*Af)Ptilde ! acsrm1 = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i) ! Doing it this way means to consider diag(Af_i)
! !
! !
call psb_symbmm(af,am4,am1,info) call psb_symbmm(acsrf,acsr4,acsr1,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999 goto 9999
end if end if
call psb_numbmm(af,am4,am1) call psb_numbmm(acsrf,acsr4,acsr1)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done NUMBMM 1'
else else
! !
! Build the smoothed prolongator using the original matrix ! Build the smoothed prolongator using the original matrix
! !
if (psb_toupper(am3%fida) == 'CSR') then do i=1,acsr3%get_nrows()
do i=1,am3%m do j=acsr3%irp(i),acsr3%irp(i+1)-1
do j=am3%ia2(i),am3%ia2(i+1)-1 if (acsr3%ja(j) == i) then
if (am3%ia1(j) == i) then acsr3%val(j) = sone - omega*acsr3%val(j)
am3%aspk(j) = sone - omega*am3%aspk(j) else
else acsr3%val(j) = - omega*acsr3%val(j)
am3%aspk(j) = - omega*am3%aspk(j) end if
end if
end do
end do end do
else end do
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format')
goto 9999
end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
@ -429,30 +391,27 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
! !
! Symbmm90 does the allocation for its result. ! Symbmm90 does the allocation for its result.
! !
! am1 = (I-w*D*A)Ptilde ! acsrm1 = (I-w*D*A)Ptilde
! Doing it this way means to consider diag(A_i) ! Doing it this way means to consider diag(A_i)
! !
! !
call psb_symbmm(am3,am4,am1,info) call psb_symbmm(acsr3,acsr4,acsr1,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999 goto 9999
end if end if
call psb_numbmm(am3,am4,am1) call psb_numbmm(acsr3,acsr4,acsr1)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done NUMBMM 1'
end if end if
call acsr4%free()
call acsr1%set_dupl(psb_dupl_add_)
call psb_sp_free(am4,info) call am1%mv_from(acsr1)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_free')
goto 9999
end if
if (ml_global_nmb) then if (ml_global_nmb) then
! !
! Now we have to gather the halo of am1, and add it to itself ! Now we have to gather the halo of am1, and add it to itself
@ -461,7 +420,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_sphalo(am1,desc_a,am4,info,& call psb_sphalo(am1,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.) & colcnv=.false.,rowscale=.true.)
if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4)
if (info == psb_success_) call psb_sp_free(am4,info) if (info == psb_success_) call am4%free()
else else
call psb_rwextd(ncol,am1,info) call psb_rwextd(ncol,am1,info)
endif endif
@ -479,32 +438,35 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_numbmm(a,am1,am3) call psb_numbmm(a,am1,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2' & 'Done NUMBMM 2',p%iprcparm(mld_aggr_kind_), mld_smooth_prol_
if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then
call psb_transp(am1,am2,fmt='COO') call am2%transp(am1)
nzl = am2%infoa(psb_nnz_) call am2%mv_to(acoo2)
nzl = acoo2%get_nzeros()
i=0 i=0
! !
! Now we have to fix this. The only rows of B that are correct ! Now we have to fix this. The only rows of B that are correct
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
! !
do k=1, nzl do k=1, nzl
if ((naggrm1 < am2%ia1(k)) .and.(am2%ia1(k) <= naggrp1)) then if ((naggrm1 < acoo2%ia(k)) .and.(acoo2%ia(k) <= naggrp1)) then
i = i+1 i = i+1
am2%aspk(i) = am2%aspk(k) acoo2%val(i) = acoo2%val(k)
am2%ia1(i) = am2%ia1(k) acoo2%ia(i) = acoo2%ia(k)
am2%ia2(i) = am2%ia2(k) acoo2%ja(i) = acoo2%ja(k)
end if end if
end do end do
am2%infoa(psb_nnz_) = i call acoo2%set_nzeros(i)
call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_) call acoo2%trim()
call am2%mv_from(acoo2)
call am2%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv am2') call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv am2')
goto 9999 goto 9999
end if end if
else else
call psb_transp(am1,am2) call am2%transp(am1)
endif endif
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
@ -515,7 +477,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_sphalo(am3,desc_a,am4,info,& call psb_sphalo(am3,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.) & colcnv=.false.,rowscale=.true.)
if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4)
if (info == psb_success_) call psb_sp_free(am4,info) if (info == psb_success_) call am4%free()
else if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then else if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then
call psb_rwextd(ncol,am3,info) call psb_rwextd(ncol,am3,info)
endif endif
@ -530,8 +492,8 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
& 'starting symbmm 3' & 'starting symbmm 3'
call psb_symbmm(am2,am3,b,info) call psb_symbmm(am2,am3,b,info)
if (info == psb_success_) call psb_numbmm(am2,am3,b) if (info == psb_success_) call psb_numbmm(am2,am3,b)
if (info == psb_success_) call psb_sp_free(am3,info) if (info == psb_success_) call am3%free()
if (info == psb_success_) call psb_spcnv(b,info,afmt='coo',dupl=psb_dupl_add_) if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = am2 x am3') call psb_errpush(psb_err_internal_error_,name,a_err='Build b = am2 x am3')
goto 9999 goto 9999
@ -547,14 +509,15 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
case(mld_distr_mat_) case(mld_distr_mat_)
call psb_sp_clone(b,p%ac,info) nzac = b%get_nzeros()
nzac = p%ac%infoa(psb_nnz_) nzl = nzac
nzl = p%ac%infoa(psb_nnz_) call b%mv_to(bcoo)
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,p%ac%ia1,p%ac%ia2,p%desc_ac,info) if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info) if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(p%ac%ia1(1:nzl),p%desc_ac,info,iact='I') if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(p%ac%ia2(1:nzl),p%desc_ac,info,iact='I') if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Creating p%desc_ac and converting ac') call psb_errpush(psb_err_internal_error_,name,a_err='Creating p%desc_ac and converting ac')
goto 9999 goto 9999
@ -562,14 +525,12 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Assembld aux descr. distr.' & 'Assembld aux descr. distr.'
call p%ac%mv_from(bcoo)
call p%ac%set_nrows(psb_cd_get_local_rows(p%desc_ac))
call p%ac%set_ncols(psb_cd_get_local_cols(p%desc_ac))
call p%ac%set_asb()
p%ac%m=psb_cd_get_local_rows(p%desc_ac)
p%ac%k=psb_cd_get_local_cols(p%desc_ac)
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_sp_free(b,info)
if (info == psb_success_) deallocate(nzbr,idisp,stat=info) if (info == psb_success_) deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
@ -577,26 +538,31 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
if (np>1) then if (np>1) then
nzl = psb_sp_get_nnzeros(am1) call am1%mv_to(acsr1)
call psb_glob_to_loc(am1%ia1(1:nzl),p%desc_ac,info,'I') nzl = acsr1%get_nzeros()
call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999 goto 9999
end if end if
call am1%mv_from(acsr1)
endif endif
am1%k=psb_cd_get_local_cols(p%desc_ac) call am1%set_ncols(psb_cd_get_local_cols(p%desc_ac))
if (np>1) then if (np>1) then
call psb_spcnv(am2,info,afmt='coo',dupl=psb_dupl_add_) call am2%cscnv(info,type='coo',dupl=psb_dupl_add_)
nzl = am2%infoa(psb_nnz_) call am2%mv_to(acoo2)
if (info == psb_success_) call psb_glob_to_loc(am2%ia1(1:nzl),p%desc_ac,info,'I') nzl = acoo2%get_nzeros()
if (info == psb_success_) call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_) if (info == psb_success_) call psb_glob_to_loc(acoo2%ia(1:nzl),p%desc_ac,info,'I')
call acoo2%set_dupl(psb_dupl_add_)
if (info == psb_success_) call am2%mv_from(acoo2)
if (info == psb_success_) call am2%cscnv(info,type='csr')
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local')
goto 9999 goto 9999
end if end if
end if end if
am2%m=psb_cd_get_local_cols(p%desc_ac) call am2%set_nrows(psb_cd_get_local_cols(p%desc_ac))
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
@ -606,39 +572,43 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
! !
! !
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
nzbr(:) = 0 if (.false.) then
nzbr(me+1) = b%infoa(psb_nnz_) nzbr(:) = 0
nzbr(me+1) = b%get_nzeros()
call psb_sum(ictxt,nzbr(1:np)) call b%mv_to(bcoo)
nzac = sum(nzbr) call psb_sum(ictxt,nzbr(1:np))
if (info == psb_success_) call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info) nzac = sum(nzbr)
if (info /= psb_success_) goto 9999 if (info == psb_success_) call cootmp%allocate(ntaggr,ntaggr,nzac)
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1)) do ip=1,np
enddo idisp(ip) = sum(nzbr(1:ip-1))
ndx = nzbr(me+1) enddo
ndx = nzbr(me+1)
call mpi_allgatherv(b%aspk,ndx,mpi_real,p%ac%aspk,nzbr,idisp,&
& mpi_real,icomm,info) call mpi_allgatherv(bcoo%val,ndx,mpi_real,&
if (info == psb_success_) call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,& & cootmp%val,nzbr,idisp,&
& mpi_integer,icomm,info) & mpi_double_precision,icomm,info)
if (info == psb_success_) call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,& if (info == psb_success_) call mpi_allgatherv(bcoo%ia,ndx,mpi_integer,&
& mpi_integer,icomm,info) & cootmp%ia,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info /= psb_success_) then if (info == psb_success_) call mpi_allgatherv(bcoo%ja,ndx,mpi_integer,&
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') & cootmp%ja,nzbr,idisp,&
goto 9999 & mpi_integer,icomm,info)
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv')
goto 9999
end if
call bcoo%free()
p%ac%m = ntaggr call cootmp%set_nzeros(nzac)
p%ac%k = ntaggr call cootmp%set_dupl(psb_dupl_add_)
p%ac%infoa(psb_nnz_) = nzac call p%ac%mv_from(cootmp)
p%ac%fida='COO' else
p%ac%descra='GUN' call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_) endif
if(info /= psb_success_) goto 9999 if(info /= psb_success_) goto 9999
call psb_sp_free(b,info)
if(info /= psb_success_) goto 9999 if(info /= psb_success_) goto 9999
deallocate(nzbr,idisp,stat=info) deallocate(nzbr,idisp,stat=info)
@ -660,10 +630,9 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
case(mld_distr_mat_) case(mld_distr_mat_)
call psb_sp_clone(b,p%ac,info) call psb_move_alloc(b,p%ac,info)
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info) if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_sp_free(b,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Build desc_ac, ac') call psb_errpush(psb_err_from_subroutine_,name,a_err='Build desc_ac, ac')
goto 9999 goto 9999
@ -678,47 +647,14 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall')
goto 9999 goto 9999
end if end if
call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if(info /= psb_success_) goto 9999
nzbr(:) = 0
nzbr(me+1) = b%infoa(psb_nnz_)
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_all')
goto 9999
end if
do ip=1,np deallocate(nzbr,idisp,stat=info)
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(b%aspk,ndx,mpi_real,p%ac%aspk,nzbr,idisp,&
& mpi_real,icomm,info)
if (info == psb_success_) call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info == psb_success_) call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') info = psb_err_alloc_dealloc_
goto 9999 call psb_errpush(info,name)
end if
p%ac%m = ntaggr
p%ac%k = ntaggr
p%ac%infoa(psb_nnz_) = nzac
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
call psb_sp_free(b,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
goto 9999 goto 9999
end if end if
@ -742,7 +678,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
end select end select
call psb_spcnv(p%ac,info,afmt='csr',dupl=psb_dupl_add_) call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999 goto 9999
@ -755,8 +691,8 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
! !
p%map = psb_linmap(psb_map_aggr_,desc_a,& p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1,ilaggr,nlaggr) & p%desc_ac,am2,am1,ilaggr,nlaggr)
if (info == psb_success_) call psb_sp_free(am1,info) if (info == psb_success_) call am1%free()
if (info == psb_success_) call psb_sp_free(am2,info) if (info == psb_success_) call am2%free()
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999 goto 9999

407
mlprec/mld_sas_aply.f90
Unescape Escape View File

@ -1,407 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_sas_aply.f90
!
! Subroutine: mld_sas_aply
! Version: real
!
! This routine applies the Additive Schwarz preconditioner by computing
!
! Y = beta*Y + alpha*op(K^(-1))*X,
! where
! - K is the base preconditioner, stored in prec,
! - op(K^(-1)) is K^(-1) or its transpose, according to the value of trans,
! - X and Y are vectors,
! - alpha and beta are scalars.
!
!
! Arguments:
! alpha - real(psb_spk_), input.
! The scalar alpha.
! prec - type(mld_sbaseprec_type), input.
! The base preconditioner data structure containing the local part
! of the preconditioner K.
! x - real(psb_spk_), dimension(:), input.
! The local part of the vector X.
! beta - real(psb_spk_), input.
! The scalar beta.
! y - real(psb_spk_), dimension(:), input/output.
! The local part of the vector Y.
! desc_data - type(psb_desc_type), input.
! The communication descriptor associated to the matrix to be
! preconditioned.
! trans - character, optional.
! If trans='N','n' then op(K^(-1)) = K^(-1);
! if trans='T','t' then op(K^(-1)) = K^(-T) (transpose of K^(-1)).
! work - real(psb_spk_), dimension (:), optional, target.
! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data).
! info - integer, output.
! Error code.
!
subroutine mld_sas_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_sas_aply
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_sbaseprec_type), intent(in) :: prec
real(psb_spk_),intent(in) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
real(psb_spk_),intent(in) :: alpha,beta
character(len=1) :: trans
real(psb_spk_),target :: work(:)
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col, int_err(5), nrow_d
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,isz, err_act
character(len=20) :: name, ch_err
character :: trans_
name='mld_sas_aply'
info = psb_success_
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc_data)
call psb_info(ictxt, me, np)
trans_ = psb_toupper(trans)
select case(prec%iprcparm(mld_smoother_type_))
case(mld_bjac_)
call mld_sub_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_sub_aply'
goto 9999
end if
case(mld_as_)
!
! Additive Schwarz preconditioner
!
if ((prec%iprcparm(mld_sub_ovr_) == 0).or.(np==1)) then
!
! Shortcut: this fixes performance for RAS(0) == BJA
!
call mld_sub_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_sub_aply'
goto 9999
end if
else
!
! Overlap > 0
!
n_row = psb_cd_get_local_rows(prec%desc_data)
n_col = psb_cd_get_local_cols(prec%desc_data)
nrow_d = psb_cd_get_local_rows(desc_data)
isz=max(n_row,N_COL)
if ((6*isz) <= size(work)) then
ww => work(1:isz)
tx => work(isz+1:2*isz)
ty => work(2*isz+1:3*isz)
aux => work(3*isz+1:)
else if ((4*isz) <= size(work)) then
aux => work(1:)
allocate(ww(isz),tx(isz),ty(isz),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_request_,name,i_err=(/3*isz,0,0,0,0/),&
& a_err='real(psb_spk_)')
goto 9999
end if
else if ((3*isz) <= size(work)) then
ww => work(1:isz)
tx => work(isz+1:2*isz)
ty => work(2*isz+1:3*isz)
allocate(aux(4*isz),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),&
& a_err='real(psb_spk_)')
goto 9999
end if
else
allocate(ww(isz),tx(isz),ty(isz),&
&aux(4*isz),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_request_,name,i_err=(/4*isz,0,0,0,0/),&
& a_err='real(psb_spk_)')
goto 9999
end if
endif
tx(1:nrow_d) = x(1:nrow_d)
tx(nrow_d+1:isz) = szero
select case(trans_)
case('N')
!
! Get the overlap entries of tx (tx == x)
!
if (prec%iprcparm(mld_sub_restr_) == psb_halo_) then
call psb_halo(tx,prec%desc_data,info,work=aux,data=psb_comm_ext_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_halo'
goto 9999
end if
else if (prec%iprcparm(mld_sub_restr_) /= psb_none_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_')
goto 9999
end if
!
! If required, reorder tx according to the row/column permutation of the
! local extended matrix, stored into the permutation vector prec%perm
!
if (prec%iprcparm(mld_sub_ren_)>0) then
call psb_gelp('n',prec%perm,tx,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_gelp'
goto 9999
end if
endif
!
! Apply to tx the block-Jacobi preconditioner/solver (multiple sweeps of the
! block-Jacobi solver can be applied at the coarsest level of a multilevel
! preconditioner). The resulting vector is ty.
!
call mld_sub_aply(sone,prec,tx,szero,ty,prec%desc_data,trans_,aux,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_bjac_aply'
goto 9999
end if
!
! Apply to ty the inverse permutation of prec%perm
!
if (prec%iprcparm(mld_sub_ren_)>0) then
call psb_gelp('n',prec%invperm,ty,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_gelp'
goto 9999
end if
endif
select case (prec%iprcparm(mld_sub_prol_))
case(psb_none_)
!
! Would work anyway, but since it is supposed to do nothing ...
! call psb_ovrl(ty,prec%desc_data,info,&
! & update=prec%iprcparm(mld_sub_prol_),work=aux)
case(psb_sum_,psb_avg_)
!
! Update the overlap of ty
!
call psb_ovrl(ty,prec%desc_data,info,&
& update=prec%iprcparm(mld_sub_prol_),work=aux)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_ovrl'
goto 9999
end if
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_')
goto 9999
end select
case('T','C')
!
! With transpose, we have to do it here
!
select case (prec%iprcparm(mld_sub_prol_))
case(psb_none_)
!
! Do nothing
case(psb_sum_)
!
! The transpose of sum is halo
!
call psb_halo(tx,prec%desc_data,info,work=aux,data=psb_comm_ext_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_halo'
goto 9999
end if
case(psb_avg_)
!
! Tricky one: first we have to scale the overlap entries,
! which we can do by assignind mode=0, i.e. no communication
! (hence only scaling), then we do the halo
!
call psb_ovrl(tx,prec%desc_data,info,&
& update=psb_avg_,work=aux,mode=0)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_ovrl'
goto 9999
end if
call psb_halo(tx,prec%desc_data,info,work=aux,data=psb_comm_ext_)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_halo'
goto 9999
end if
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_prol_')
goto 9999
end select
!
! If required, reorder tx according to the row/column permutation of the
! local extended matrix, stored into the permutation vector prec%perm
!
if (prec%iprcparm(mld_sub_ren_)>0) then
call psb_gelp('n',prec%perm,tx,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_gelp'
goto 9999
end if
endif
!
! Apply to tx the block-Jacobi preconditioner/solver (multiple sweeps of the
! block-Jacobi solver can be applied at the coarsest level of a multilevel
! preconditioner). The resulting vector is ty.
!
call mld_sub_aply(sone,prec,tx,szero,ty,prec%desc_data,trans_,aux,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_bjac_aply'
goto 9999
end if
!
! Apply to ty the inverse permutation of prec%perm
!
if (prec%iprcparm(mld_sub_ren_)>0) then
call psb_gelp('n',prec%invperm,ty,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_gelp'
goto 9999
end if
endif
!
! With transpose, we have to do it here
!
if (prec%iprcparm(mld_sub_restr_) == psb_halo_) then
call psb_ovrl(ty,prec%desc_data,info,&
& update=psb_sum_,work=aux)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_ovrl'
goto 9999
end if
else if (prec%iprcparm(mld_sub_restr_) /= psb_none_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_sub_restr_')
goto 9999
end if
case default
info=psb_err_iarg_invalid_i_
int_err(1)=6
ch_err(2:2)=trans
goto 9999
end select
!
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
!
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if ((6*isz) <= size(work)) then
else if ((4*isz) <= size(work)) then
deallocate(ww,tx,ty)
else if ((3*isz) <= size(work)) then
deallocate(aux)
else
deallocate(ww,aux,tx,ty)
endif
end if
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_smoother_type_')
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_sas_aply

287
mlprec/mld_sas_bld.f90
Unescape Escape View File

@ -1,287 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_sas_bld.f90
!
! Subroutine: mld_sas_bld
! Version: real
!
! This routine builds Additive Schwarz (AS) preconditioners. If the AS
! preconditioner is actually the block-Jacobi one, the routine makes only a
! copy of the descriptor of the original matrix and then calls mld_fact_bld
! to perform an LU or ILU factorization of the diagonal blocks of the
! distributed matrix.
!
!
! Arguments:
! a - type(psb_dspmat_type), input.
! The sparse matrix structure containing the local part of the
! matrix to be preconditioned.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of the sparse matrix a.
! p - type(mld_sbaseprec_type), input/output.
! The 'base preconditioner' data structure containing the local
! part of the preconditioner or solver to be built.
! upd - character, input.
! If upd='F' then the preconditioner is built from scratch;
! if upd=T' then the matrix to be preconditioned has the same
! sparsity pattern of a matrix that has been previously
! preconditioned, hence some information is reused in building
! the new preconditioner.
! info - integer, output.
! Error code.
!
subroutine mld_sas_bld(a,desc_a,p,upd,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_sas_bld
Implicit None
! Arguments
type(psb_sspmat_type), intent(in), target :: a
Type(psb_desc_type), Intent(in) :: desc_a
type(mld_sbaseprec_type), intent(inout) :: p
character, intent(in) :: upd
integer, intent(out) :: info
! Local variables
integer :: ptype,novr
integer :: icomm
Integer :: np,me,nnzero,ictxt, int_err(5),&
& tot_recv, n_row,n_col,nhalo, err_act, data_
type(psb_sspmat_type) :: blck
integer :: debug_level, debug_unit
character(len=20) :: name, ch_err
name='mld_as_bld'
if(psb_get_errstatus() /= 0) return
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
If (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' start ', upd
ictxt = psb_cd_get_context(desc_a)
icomm = psb_cd_get_mpic(desc_a)
Call psb_info(ictxt, me, np)
tot_recv=0
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
nnzero = psb_sp_get_nnzeros(a)
nhalo = n_col-n_row
ptype = p%iprcparm(mld_smoother_type_)
novr = p%iprcparm(mld_sub_ovr_)
select case (ptype)
case(mld_bjac_)
!
! Block Jacobi
!
data_ = psb_no_comm_
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling desccpy'
if (upd == 'F') then
call psb_cdcpy(desc_a,p%desc_data,info)
If(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' done cdcpy'
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Early return: P>=3 N_OVR=0'
endif
call psb_sp_all(0,0,blck,1,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
blck%fida = 'COO'
blck%infoa(psb_nnz_) = 0
call mld_fact_bld(a,p,upd,info,blck=blck)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_fact_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(mld_as_)
!
! Additive Schwarz
!
if (novr < 0) then
info=psb_err_invalid_ovr_num_
int_err(1)=novr
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
if ((novr == 0).or.(np == 1)) then
!
! Actually, this is just block Jacobi
!
data_ = psb_no_comm_
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling desccpy'
if (upd == 'F') then
call psb_cdcpy(desc_a,p%desc_data,info)
If(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' done cdcpy'
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Early return: P>=3 N_OVR=0'
endif
call psb_sp_all(0,0,blck,1,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
blck%fida = 'COO'
blck%infoa(psb_nnz_) = 0
else
If (upd == 'F') Then
!
! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_).
! This is done by psb_cdbldext (interface to psb_cdovr), which is
! independent of CSR, and has been placed in the tools directory
! of PSBLAS, instead of the mlprec directory of MLD2P4, because it
! might be used independently of the AS preconditioner, to build
! a descriptor for an extended stencil in a PDE solver.
!
call psb_cdbldext(a,desc_a,novr,p%desc_data,info,extype=psb_ovt_asov_)
if(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' From cdbldext _:',p%desc_data%matrix_data(psb_n_row_),&
& p%desc_data%matrix_data(psb_n_col_)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_cdbldext'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
Endif
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Before sphalo ',blck%fida,blck%m,psb_nnz_,blck%infoa(psb_nnz_)
!
! Retrieve the remote sparse matrix rows required for the AS extended
! matrix
data_ = psb_comm_ext_
Call psb_sphalo(a,p%desc_data,blck,info,data=data_,rowscale=.true.)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_sphalo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'After psb_sphalo ',&
& blck%fida,blck%m,psb_nnz_,blck%infoa(psb_nnz_)
End if
call mld_fact_bld(a,p,upd,info,blck=blck)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_fact_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case default
info=psb_err_internal_error_
ch_err='Invalid ptype'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
End select
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),'Done'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
Return
End Subroutine mld_sas_bld

189
mlprec/mld_sbaseprec_aply.f90
Unescape Escape View File

@ -1,189 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_sbaseprec_aply.f90
!
! Subroutine: mld_sbaseprec_aply
! Version: real
!
! This routine applies a base preconditioner by computing
!
! Y = beta*Y + alpha*op(K^(-1))*X,
! where
! - K is the base preconditioner, stored in prec,
! - op(K^(-1)) is K^(-1) or its transpose, according to the value of trans,
! - X and Y are vectors,
! - alpha and beta are scalars.
!
! The routine is used by mld_smlprec_aply, to apply the multilevel preconditioners,
! or directly by mld_sprec_aply, to apply the basic one-level preconditioners (diagonal,
! block-Jacobi or additive Schwarz). It also manages the case of no preconditioning.
!
!
! Arguments:
! alpha - real(psb_spk_), input.
! The scalar alpha.
! prec - type(mld_sbaseprec_type), input.
! The base preconditioner data structure containing the local part
! of the preconditioner K.
! x - real(psb_spk_), dimension(:), input.
! The local part of the vector X.
! beta - real(psb_spk_), input.
! The scalar beta.
! y - real(psb_spk_), dimension(:), input/output.
! The local part of the vector Y.
! desc_data - type(psb_desc_type), input.
! The communication descriptor associated to the matrix to be
! preconditioned.
! trans - character, optional.
! If trans='N','n' then op(K^(-1)) = K^(-1);
! if trans='T','t' then op(K^(-1)) = K^(-T) (transpose of K^(-1)).
! work - real(psb_spk_), dimension (:), optional, target.
! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data).
! info - integer, output.
! Error code.
!
subroutine mld_sbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_sbaseprec_aply
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_sbaseprec_type), intent(in) :: prec
real(psb_spk_),intent(in) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
real(psb_spk_),intent(in) :: alpha,beta
character(len=1) :: trans
real(psb_spk_),target :: work(:)
integer, intent(out) :: info
! Local variables
real(psb_spk_), pointer :: ww(:)
integer :: ictxt, np, me, err_act
integer :: n_row, int_err(5)
character(len=20) :: name, ch_err
character :: trans_
name='mld_sbaseprec_aply'
info = psb_success_
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc_data)
call psb_info(ictxt, me, np)
trans_= psb_toupper(trans)
select case(trans_)
case('N','T','C')
! Ok
case default
info=psb_err_iarg_invalid_i_
int_err(1)=6
ch_err(2:2)=trans
goto 9999
end select
select case(prec%iprcparm(mld_smoother_type_))
case(mld_noprec_)
!
! No preconditioner
!
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
case(mld_diag_)
!
! Diagonal preconditioner
!
if (size(work) >= size(x)) then
ww => work
else
allocate(ww(size(x)),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_request_,name,i_err=(/size(x),0,0,0,0/),a_err='real(psb_spk_)')
goto 9999
end if
end if
n_row = psb_cd_get_local_rows(desc_data)
ww(1:n_row) = x(1:n_row)*prec%d(1:n_row)
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
if (size(work) < size(x)) then
deallocate(ww,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Deallocate')
goto 9999
end if
end if
case(mld_bjac_,mld_as_)
!
! Additive Schwarz preconditioner (including block-Jacobi as special case)
!
call mld_as_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_as_aply'
goto 9999
end if
case default
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid mld_smoother_type_')
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_sbaseprec_aply

215
mlprec/mld_sbaseprec_bld.f90
Unescape Escape View File

@ -1,215 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_sbaseprec_bld.f90
!
! Subroutine: mld_sbaseprec_bld
! Version: real
!
! This routine builds a 'base preconditioner' related to a matrix A.
! In a multilevel framework, it is called by mld_mlprec_bld to build the
! base preconditioner at each level.
!
! Details on the base preconditioner to be built are stored in the iprcparm
! field of the base preconditioner data structure (for a description of this
! data structure see mld_prec_type.f90).
!
!
! Arguments:
! a - type(psb_sspmat_type).
! The sparse matrix structure containing the local part of the
! matrix A to be preconditioned.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of a.
! p - type(mld_sbaseprec_type), input/output.
! The 'base preconditioner' data structure containing the local
! part of the preconditioner at the selected level.
! info - integer, output.
! Error code.
! upd - character, input, optional.
! If upd='F' then the base preconditioner is built from
! scratch; if upd=T' then the matrix to be preconditioned
! has the same sparsity pattern of a matrix that has been
! previously preconditioned, hence some information is reused
! in building the new preconditioner.
!
subroutine mld_sbaseprec_bld(a,desc_a,p,info,upd)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_sbaseprec_bld
Implicit None
! Arguments
type(psb_sspmat_type), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_sbaseprec_type),intent(inout) :: p
integer, intent(out) :: info
character, intent(in), optional :: upd
! Local variables
Integer :: err, n_row, n_col,ictxt, me,np,mglob, err_act
character :: iupd
integer :: debug_level, debug_unit
character(len=20) :: name, ch_err
if (psb_get_errstatus() /= 0) return
name = 'mld_sbaseprec_bld'
info=psb_success_
err=0
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc_a)
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
mglob = psb_cd_get_global_rows(desc_a)
call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' start'
if (present(upd)) then
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),'UPD ', upd
if ((psb_toupper(UPD) == 'F').or.(psb_toupper(UPD) == 'T')) then
IUPD=psb_toupper(UPD)
else
IUPD='F'
endif
else
IUPD='F'
endif
!
! Should add check to ensure all procs have the same...
!
call mld_check_def(p%iprcparm(mld_smoother_type_),'base_prec',&
& mld_diag_,is_legal_base_prec)
call psb_nullify_desc(p%desc_data)
select case(p%iprcparm(mld_smoother_type_))
case (mld_noprec_)
! No preconditioner
! Do nothing
call psb_cdcpy(desc_a,p%desc_data,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case (mld_diag_)
! Diagonal preconditioner
call mld_diag_bld(a,desc_a,p,info)
if(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': out of mld_diag_bld'
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_diag_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(mld_bjac_,mld_as_)
! Additive Schwarz preconditioners/smoothers
call mld_check_def(p%iprcparm(mld_sub_ovr_),'overlap',&
& 0,is_legal_n_ovr)
call mld_check_def(p%iprcparm(mld_sub_restr_),'restriction',&
& psb_halo_,is_legal_restrict)
call mld_check_def(p%iprcparm(mld_sub_prol_),'prolongator',&
& psb_none_,is_legal_prolong)
call mld_check_def(p%iprcparm(mld_sub_ren_),'renumbering',&
& mld_renum_none_,is_legal_renum)
call mld_check_def(p%iprcparm(mld_sub_solve_),'fact',&
& mld_ilu_n_,is_legal_ml_fact)
! Set parameters for using SuperLU_dist on the local submatrices
if (p%iprcparm(mld_sub_solve_) == mld_sludist_) then
p%iprcparm(mld_sub_ovr_) = 0
p%iprcparm(mld_smoother_sweeps_) = 1
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': Calling mld_as_bld'
! Build the local part of the base preconditioner/smoother
call mld_as_bld(a,desc_a,p,iupd,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='mld_as_bld')
goto 9999
end if
case default
info=psb_err_internal_error_
ch_err='Unknown mld_smoother_type_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
p%iprcparm(mld_prec_status_) = mld_prec_built_
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Done'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_sbaseprec_bld

12
mlprec/mld_scoarse_bld.f90
Unescape Escape View File

@ -79,11 +79,9 @@ subroutine mld_scoarse_bld(a,desc_a,p,info)
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
type(psb_desc_type) :: desc_ac character(len=20) :: name
type(psb_sspmat_type) :: ac integer :: ictxt, np, me, err_act
character(len=20) :: name integer, allocatable :: ilaggr(:), nlaggr(:)
integer :: ictxt, np, me, err_act
integer, allocatable :: ilaggr(:), nlaggr(:)
name='mld_scoarse_bld' name='mld_scoarse_bld'
if (psb_get_errstatus().ne.0) return if (psb_get_errstatus().ne.0) return
@ -125,7 +123,8 @@ subroutine mld_scoarse_bld(a,desc_a,p,info)
! !
call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),p%rprcparm(mld_aggr_thresh_),& call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),p%rprcparm(mld_aggr_thresh_),&
& a,desc_a,ilaggr,nlaggr,info) & a,desc_a,ilaggr,nlaggr,info)
if(info /= psb_success_) then
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmap_bld') call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmap_bld')
goto 9999 goto 9999
end if end if
@ -136,6 +135,7 @@ subroutine mld_scoarse_bld(a,desc_a,p,info)
! algorithm specified by p%iprcparm(mld_aggr_kind_) ! algorithm specified by p%iprcparm(mld_aggr_kind_)
! !
call mld_aggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) call mld_aggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_asb') call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_asb')
goto 9999 goto 9999

490
mlprec/mld_silu0_fact.f90
Unescape Escape View File

@ -99,10 +99,10 @@
! greater than 0. If the overlap is 0 or the matrix has been reordered ! greater than 0. If the overlap is 0 or the matrix has been reordered
! (see mld_fact_bld), then blck is empty. ! (see mld_fact_bld), then blck is empty.
! !
subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck) subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck,upd)
use psb_sparse_mod use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_silu0_fact use mld_inner_mod!, mld_protect_name => mld_silu0_fact
implicit none implicit none
@ -113,11 +113,14 @@ subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck)
real(psb_spk_), intent(inout) :: d(:) real(psb_spk_), intent(inout) :: d(:)
integer, intent(out) :: info integer, intent(out) :: info
type(psb_sspmat_type),intent(in), optional, target :: blck type(psb_sspmat_type),intent(in), optional, target :: blck
character, intent(in), optional :: upd
! Local variables ! Local variables
integer :: l1, l2,m,err_act integer :: l1, l2, m, err_act
type(psb_sspmat_type), pointer :: blck_ type(psb_sspmat_type), pointer :: blck_
character(len=20) :: name, ch_err type(psb_s_csr_sparse_mat) :: ll, uu
character :: upd_
character(len=20) :: name, ch_err
name='mld_silu0_fact' name='mld_silu0_fact'
info = psb_success_ info = psb_success_
@ -130,28 +133,36 @@ subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck)
blck_ => blck blck_ => blck
else else
allocate(blck_,stat=info) allocate(blck_,stat=info)
if (info /= psb_success_) then if (info == psb_success_) call blck_%csall(0,0,info,1)
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') if (info /= psb_success_) then
goto 9999
end if
call psb_nullify_sp(blck_) ! Probably pointless.
call psb_sp_all(0,0,blck_,1,info)
if(info.ne.0) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_sp_all' ch_err='csall'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
blck_%m=0
endif endif
if (present(upd)) then
upd_ = psb_toupper(upd)
else
upd_ = 'F'
end if
m = a%get_nrows() + blck_%get_nrows()
if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.&
& (m > size(d)) ) then
write(0,*) 'Wrong allocation status for L,D,U? ',&
& l%get_nrows(),size(d),u%get_nrows()
info = -1
return
end if
call l%mv_to(ll)
call u%mv_to(uu)
! !
! Compute the ILU(0) or the MILU(0) factorization, depending on ialg ! Compute the ILU(0) or the MILU(0) factorization, depending on ialg
! !
call mld_silu0_factint(ialg,m,a%m,a,blck_%m,blck_,& call mld_silu0_factint(ialg,a,blck_,&
& d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,upd_,info)
if(info.ne.0) then if(info.ne.0) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mld_silu0_factint' ch_err='mld_silu0_factint'
@ -162,24 +173,22 @@ subroutine mld_silu0_fact(ialg,a,l,u,d,info,blck)
! !
! Store information on the L and U sparse matrices ! Store information on the L and U sparse matrices
! !
l%infoa(1) = l1 call l%mv_from(ll)
l%fida = 'CSR' call l%set_triangle()
l%descra = 'TLU' call l%set_unit()
u%infoa(1) = l2 call l%set_lower()
u%fida = 'CSR' call u%mv_from(uu)
u%descra = 'TUU' call u%set_triangle()
l%m = m call u%set_unit()
l%k = m call u%set_upper()
u%m = m
u%k = m
! !
! Nullify pointer / deallocate memory ! Nullify pointer / deallocate memory
! !
if (present(blck)) then if (present(blck)) then
blck_ => null() blck_ => null()
else else
call psb_sp_free(blck_,info) call blck_%free()
if(info.ne.0) then if(info.ne.0) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_sp_free' ch_err='psb_sp_free'
@ -277,24 +286,25 @@ contains
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_silu0_factint(ialg,m,ma,a,mb,b,& subroutine mld_silu0_factint(ialg,a,b,&
& d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info) & d,lval,lja,lirp,uval,uja,uirp,l1,l2,upd,info)
implicit none implicit none
! Arguments ! Arguments
integer, intent(in) :: ialg integer, intent(in) :: ialg
type(psb_sspmat_type),intent(in) :: a,b type(psb_sspmat_type),intent(in) :: a,b
integer,intent(inout) :: m,l1,l2,info integer,intent(inout) :: l1,l2,info
integer, intent(in) :: ma,mb integer, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:)
integer, dimension(:), intent(inout) :: lia1,lia2,uia1,uia2 real(psb_spk_), intent(inout) :: lval(:),uval(:),d(:)
real(psb_spk_), dimension(:),intent(inout) :: laspk,uaspk,d character, intent(in) :: upd
! Local variables ! Local variables
integer :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act integer :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act, m
integer :: ma,mb
real(psb_spk_) :: dia,temp real(psb_spk_) :: dia,temp
integer, parameter :: nrb=16 integer, parameter :: nrb=16
type(psb_sspmat_type) :: trw type(psb_s_coo_sparse_mat) :: trw
integer :: int_err(5) integer :: int_err(5)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -302,6 +312,8 @@ contains
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=psb_success_ info=psb_success_
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ma = a%get_nrows()
mb = b%get_nrows()
select case(ialg) select case(ialg)
case(mld_ilu_n_,mld_milu_n_) case(mld_ilu_n_,mld_milu_n_)
@ -312,154 +324,152 @@ contains
goto 9999 goto 9999
end select end select
call psb_nullify_sp(trw) call trw%allocate(0,0,1)
trw%m=0 if(info /= psb_success_) then
trw%k=0
call psb_sp_all(trw,1,info)
if(info.ne.0) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_sp_all' ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
lia2(1) = 1
uia2(1) = 1
l1 = 0
l2 = 0
m = ma+mb m = ma+mb
! if (psb_toupper(upd) == 'F' ) then
! Cycle over the matrix rows lirp(1) = 1
! uirp(1) = 1
do i = 1, m l1 = 0
l2 = 0
!
! Cycle over the matrix rows
!
do i = 1, m
d(i) = szero d(i) = szero
if (i <= ma) then if (i <= ma) then
! !
! Copy the i-th local row of the matrix, stored in a, ! Copy the i-th local row of the matrix, stored in a,
! into laspk/d(i)/uaspk ! into lval/d(i)/uval
! !
call ilu_copyin(i,ma,a,i,1,m,l1,lia1,laspk,& call ilu_copyin(i,ma,a,i,1,m,l1,lja,lval,&
& d(i),l2,uia1,uaspk,ktrw,trw) & d(i),l2,uja,uval,ktrw,trw,upd)
else else
! !
! Copy the i-th local row of the matrix, stored in b ! Copy the i-th local row of the matrix, stored in b
! (as (i-ma)-th row), into laspk/d(i)/uaspk ! (as (i-ma)-th row), into lval/d(i)/uval
! !
call ilu_copyin(i-ma,mb,b,i,1,m,l1,lia1,laspk,& call ilu_copyin(i-ma,mb,b,i,1,m,l1,lja,lval,&
& d(i),l2,uia1,uaspk,ktrw,trw) & d(i),l2,uja,uval,ktrw,trw,upd)
endif endif
lia2(i+1) = l1 + 1 lirp(i+1) = l1 + 1
uia2(i+1) = l2 + 1 uirp(i+1) = l2 + 1
dia = d(i) dia = d(i)
do kk = lia2(i), lia2(i+1) - 1 do kk = lirp(i), lirp(i+1) - 1
!
! Compute entry l(i,k) (lower factor L) of the incomplete
! factorization
!
temp = laspk(kk)
k = lia1(kk)
laspk(kk) = temp*d(k)
!
! Update the rest of row i (lower and upper factors L and U)
! using l(i,k)
!
low1 = kk + 1
low2 = uia2(i)
!
updateloop: do jj = uia2(k), uia2(k+1) - 1
! !
j = uia1(jj) ! Compute entry l(i,k) (lower factor L) of the incomplete
! factorization
! !
if (j < i) then temp = lval(kk)
! k = lja(kk)
! search l(i,*) (i-th row of L) for a matching index j lval(kk) = temp*d(k)
! !
do ll = low1, lia2(i+1) - 1 ! Update the rest of row i (lower and upper factors L and U)
l = lia1(ll) ! using l(i,k)
if (l > j) then !
low1 = ll low1 = kk + 1
exit low2 = uirp(i)
else if (l == j) then !
laspk(ll) = laspk(ll) - temp*uaspk(jj) updateloop: do jj = uirp(k), uirp(k+1) - 1
low1 = ll + 1
cycle updateloop
end if
enddo
else if (j == i) then
! !
! j=i: update the diagonal j = uja(jj)
! !
dia = dia - temp*uaspk(jj) if (j < i) then
cycle updateloop !
! search l(i,*) (i-th row of L) for a matching index j
!
do ll = low1, lirp(i+1) - 1
l = lja(ll)
if (l > j) then
low1 = ll
exit
else if (l == j) then
lval(ll) = lval(ll) - temp*uval(jj)
low1 = ll + 1
cycle updateloop
end if
enddo
else if (j == i) then
!
! j=i: update the diagonal
!
dia = dia - temp*uval(jj)
cycle updateloop
!
else if (j > i) then
!
! search u(i,*) (i-th row of U) for a matching index j
!
do ll = low2, uirp(i+1) - 1
l = uja(ll)
if (l > j) then
low2 = ll
exit
else if (l == j) then
uval(ll) = uval(ll) - temp*uval(jj)
low2 = ll + 1
cycle updateloop
end if
enddo
end if
! !
else if (j > i) then ! If we get here we missed the cycle updateloop, which means
! ! that this entry does not match; thus we accumulate on the
! search u(i,*) (i-th row of U) for a matching index j ! diagonal for MILU(0).
! !
do ll = low2, uia2(i+1) - 1 if (ialg == mld_milu_n_) then
l = uia1(ll) dia = dia - temp*uval(jj)
if (l > j) then end if
low2 = ll enddo updateloop
exit enddo
else if (l == j) then !
uaspk(ll) = uaspk(ll) - temp*uaspk(jj) ! Check the pivot size
low2 = ll + 1 !
cycle updateloop if (abs(dia) < s_epstol) then
end if !
enddo ! Too small pivot: unstable factorization
end if
! !
! If we get here we missed the cycle updateloop, which means info = psb_err_pivot_too_small_
! that this entry does not match; thus we accumulate on the int_err(1) = i
! diagonal for MILU(0). write(ch_err,'(g20.10)') abs(dia)
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
goto 9999
else
! !
if (ialg == mld_milu_n_) then ! Compute 1/pivot
dia = dia - temp*uaspk(jj) !
end if dia = sone/dia
enddo updateloop end if
enddo d(i) = dia
!
! Check the pivot size
!
if (abs(dia) < s_epstol) then
!
! Too small pivot: unstable factorization
!
info = psb_err_pivot_too_small_
int_err(1) = i
write(ch_err,'(g20.10)') abs(dia)
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
goto 9999
else
! !
! Compute 1/pivot ! Scale row i of upper triangle
! !
dia = sone/dia do kk = uirp(i), uirp(i+1) - 1
end if uval(kk) = uval(kk)*dia
d(i) = dia enddo
!
! Scale row i of upper triangle
!
do kk = uia2(i), uia2(i+1) - 1
uaspk(kk) = uaspk(kk)*dia
enddo enddo
enddo else
write(0,*) 'Update not implemented '
call psb_sp_free(trw,info) info = 31
if(info.ne.0) then call psb_errpush(info,name,i_err=(/13,0,0,0,0/),a_err=upd)
info=psb_err_from_subroutine_
ch_err='psb_sp_free'
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
call trw%free()
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -480,13 +490,13 @@ contains
! This routine copies a row of a sparse matrix A, stored in the psb_sspmat_type ! This routine copies a row of a sparse matrix A, stored in the psb_sspmat_type
! data structure a, into the arrays laspk and uaspk and into the scalar variable ! data structure a, into the arrays laspk and uaspk and into the scalar variable
! dia, corresponding to the lower and upper triangles of A and to the diagonal ! dia, corresponding to the lower and upper triangles of A and to the diagonal
! entry of the row, respectively. The entries in laspk and uaspk are stored ! entry of the row, respectively. The entries in lval and uval are stored
! according to the CSR format; the corresponding column indices are stored in ! according to the CSR format; the corresponding column indices are stored in
! the arrays lia1 and uia1. ! the arrays lja and uja.
! !
! If the sparse matrix is in CSR format, a 'straight' copy is performed; ! If the sparse matrix is in CSR format, a 'straight' copy is performed;
! otherwise psb_sp_getblk is used to extract a block of rows, which is then ! otherwise psb_sp_getblk is used to extract a block of rows, which is then
! copied into laspk, dia, uaspk row by row, through successive calls to ! copied into lval, dia, uval row by row, through successive calls to
! ilu_copyin. ! ilu_copyin.
! !
! The routine is used by mld_silu0_factint in the computation of the ILU(0)/MILU(0) ! The routine is used by mld_silu0_factint in the computation of the ILU(0)/MILU(0)
@ -514,23 +524,23 @@ contains
! The output matrix will contain a clipped copy taken from ! The output matrix will contain a clipped copy taken from
! a(1:m,jmin:jmax). ! a(1:m,jmin:jmax).
! l1 - integer, input/output. ! l1 - integer, input/output.
! Pointer to the last occupied entry of laspk. ! Pointer to the last occupied entry of lval.
! lia1 - integer, dimension(:), input/output. ! lja - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the lower triangle ! The column indices of the nonzero entries of the lower triangle
! copied in laspk row by row (see mld_silu0_factint), according ! copied in lval row by row (see mld_dilu0_factint), according
! to the CSR storage format. ! to the CSR storage format.
! laspk - real(psb_spk_), dimension(:), input/output. ! lval - real(psb_spk_), dimension(:), input/output.
! The array where the entries of the row corresponding to the ! The array where the entries of the row corresponding to the
! lower triangle are copied. ! lower triangle are copied.
! dia - real(psb_spk_), output. ! dia - real(psb_spk_), output.
! The diagonal entry of the copied row. ! The diagonal entry of the copied row.
! l2 - integer, input/output. ! l2 - integer, input/output.
! Pointer to the last occupied entry of uaspk. ! Pointer to the last occupied entry of uval.
! uia1 - integer, dimension(:), input/output. ! uja - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the upper triangle ! The column indices of the nonzero entries of the upper triangle
! copied in uaspk row by row (see mld_silu0_factint), according ! copied in uval row by row (see mld_dilu0_factint), according
! to the CSR storage format. ! to the CSR storage format.
! uaspk - real(psb_spk_), dimension(:), input/output. ! uval - real(psb_spk_), dimension(:), input/output.
! The array where the entries of the row corresponding to the ! The array where the entries of the row corresponding to the
! upper triangle are copied. ! upper triangle are copied.
! ktrw - integer, input/output. ! ktrw - integer, input/output.
@ -544,8 +554,8 @@ contains
! until we empty the buffer. Thus we will make a call to psb_sp_getblk ! until we empty the buffer. Thus we will make a call to psb_sp_getblk
! every nrb calls to copyin. If A is in CSR format it is unused. ! every nrb calls to copyin. If A is in CSR format it is unused.
! !
subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lia1,laspk,& subroutine ilu_copyin(i,m,a,jd,jmin,jmax,l1,lja,lval,&
& dia,l2,uia1,uaspk,ktrw,trw) & dia,l2,uja,uval,ktrw,trw,upd)
use psb_sparse_mod use psb_sparse_mod
@ -553,83 +563,95 @@ contains
! Arguments ! Arguments
type(psb_sspmat_type), intent(in) :: a type(psb_sspmat_type), intent(in) :: a
type(psb_sspmat_type), intent(inout) :: trw type(psb_s_coo_sparse_mat), intent(inout) :: trw
integer, intent(in) :: i,m,jd,jmin,jmax integer, intent(in) :: i,m,jd,jmin,jmax
integer, intent(inout) :: ktrw,l1,l2 integer, intent(inout) :: ktrw,l1,l2
integer, intent(inout) :: lia1(:), uia1(:) integer, intent(inout) :: lja(:), uja(:)
real(psb_spk_), intent(inout) :: laspk(:), uaspk(:), dia real(psb_spk_), intent(inout) :: lval(:), uval(:), dia
character, intent(in) :: upd
! Local variables ! Local variables
integer :: k,j,info,irb integer :: k,j,info,irb, nz
integer, parameter :: nrb=16 integer, parameter :: nrb=40
character(len=20), parameter :: name='ilu_copyin' character(len=20), parameter :: name='ilu_copyin'
character(len=20) :: ch_err character(len=20) :: ch_err
if (psb_get_errstatus() /= 0) return if (psb_get_errstatus() /= 0) return
info=psb_success_ info=psb_success_
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (psb_toupper(upd) == 'F') then
if (psb_toupper(a%fida) == 'CSR') then select type(aa => a%a)
type is (psb_s_csr_sparse_mat)
! !
! Take a fast shortcut if the matrix is stored in CSR format ! Take a fast shortcut if the matrix is stored in CSR format
! !
do j = a%ia2(i), a%ia2(i+1) - 1 do j = aa%irp(i), aa%irp(i+1) - 1
k = a%ia1(j) k = aa%ja(j)
! write(0,*)'KKKKK',k ! write(0,*)'KKKKK',k
if ((k < jd).and.(k >= jmin)) then if ((k < jd).and.(k >= jmin)) then
l1 = l1 + 1 l1 = l1 + 1
laspk(l1) = a%aspk(j) lval(l1) = aa%val(j)
lia1(l1) = k lja(l1) = k
else if (k == jd) then else if (k == jd) then
dia = a%aspk(j) dia = aa%val(j)
else if ((k > jd).and.(k <= jmax)) then else if ((k > jd).and.(k <= jmax)) then
l2 = l2 + 1 l2 = l2 + 1
uaspk(l2) = a%aspk(j) uval(l2) = aa%val(j)
uia1(l2) = k uja(l2) = k
end if end if
enddo enddo
else class default
! !
! Otherwise use psb_sp_getblk, slower but able (in principle) of ! Otherwise use psb_sp_getblk, slower but able (in principle) of
! handling any format. In this case, a block of rows is extracted ! handling any format. In this case, a block of rows is extracted
! instead of a single row, for performance reasons, and these ! instead of a single row, for performance reasons, and these
! rows are copied one by one into laspk, dia, uaspk, through ! rows are copied one by one into lval, dia, uval, through
! successive calls to ilu_copyin. ! successive calls to ilu_copyin.
! !
if ((mod(i,nrb) == 1).or.(nrb == 1)) then if ((mod(i,nrb) == 1).or.(nrb == 1)) then
irb = min(m-i+1,nrb) irb = min(m-i+1,nrb)
call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1) call aa%csget(i,i+irb-1,trw,info)
if(info.ne.0) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_sp_getblk' ch_err='csget'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
ktrw=1 ktrw=1
end if
do
if (ktrw > trw%infoa(psb_nnz_)) exit
if (trw%ia1(ktrw) > i) exit
k = trw%ia2(ktrw)
if ((k < jd).and.(k >= jmin)) then
l1 = l1 + 1
laspk(l1) = trw%aspk(ktrw)
lia1(l1) = k
else if (k == jd) then
dia = trw%aspk(ktrw)
else if ((k > jd).and.(k <= jmax)) then
l2 = l2 + 1
uaspk(l2) = trw%aspk(ktrw)
uia1(l2) = k
end if end if
ktrw = ktrw + 1
enddo nz = trw%get_nzeros()
do
if (ktrw > nz) exit
if (trw%ia(ktrw) > i) exit
k = trw%ja(ktrw)
if ((k < jd).and.(k >= jmin)) then
l1 = l1 + 1
lval(l1) = trw%val(ktrw)
lja(l1) = k
else if (k == jd) then
dia = trw%val(ktrw)
else if ((k > jd).and.(k <= jmax)) then
l2 = l2 + 1
uval(l2) = trw%val(ktrw)
uja(l2) = k
end if
ktrw = ktrw + 1
enddo
end select
else
write(0,*) 'Update not implemented '
info = 31
call psb_errpush(info,name,i_err=(/13,0,0,0,0/),a_err=upd)
goto 9999
end if end if

280
mlprec/mld_silu_bld.f90
Unescape Escape View File

@ -1,280 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_silu_bld.f90
!
! Subroutine: mld_silu_bld
! Version: real
!
! This routine computes an incomplete LU (ILU) factorization of the diagonal
! blocks of a distributed matrix. This factorization is used to build the
! 'base preconditioner' (block-Jacobi preconditioner/solver, Additive Schwarz
! preconditioner) corresponding to a certain level of a multilevel preconditioner.
!
! The following factorizations are available:
! - ILU(k), i.e. ILU factorization with fill-in level k,
! - MILU(k), i.e. modified ILU factorization with fill-in level k,
! - ILU(k,t), i.e. ILU with threshold (i.e. drop tolerance) t and k additional
! entries in each row of the L and U factors with respect to the initial
! sparsity pattern.
! Note that the meaning of k in ILU(k,t) is different from that in ILU(k) and
! MILU(k).
!
! For details on the above factorizations see
! Y. Saad, Iterative Methods for Sparse Linear Systems, Second Edition,
! SIAM, 2003, Chapter 10.
!
! Note that that this routine handles the ILU(0) factorization separately,
! through mld_ilu0_fact, for performance reasons.
!
!
! Arguments:
! a - type(psb_sspmat_type), input.
! The sparse matrix structure containing the local matrix.
! Note that if p%iprcparm(mld_sub_ovr_) > 0, i.e. the
! 'base' Additive Schwarz preconditioner has overlap greater than
! 0, and p%iprcparm(mld_sub_ren_) = 0, i.e. a reordering of the
! matrix has not been performed (see mld_fact_bld), then a contains
! only the 'original' local part of the distributed matrix,
! i.e. the rows of the matrix held by the calling process according
! to the initial data distribution.
! p - type(mld_sbaseprec_type), input/output.
! The 'base preconditioner' data structure. In input, p%iprcparm
! contains information on the type of factorization to be computed.
! In output, p%av(mld_l_pr_) and p%av(mld_u_pr_) contain the
! incomplete L and U factors (without their diagonals), and p%d
! contains the diagonal of the incomplete U factor. For more
! details on p see its description in mld_prec_type.f90.
! info - integer, output.
! Error code.
! blck - type(psb_sspmat_type), input, optional.
! The sparse matrix structure containing the remote rows of the
! distributed matrix, that have been retrieved by mld_as_bld
! to build an Additive Schwarz base preconditioner with overlap
! greater than 0. If the overlap is 0 or the matrix has been reordered
! (see mld_fact_bld), then blck does not contain any row.
!
subroutine mld_silu_bld(a,p,upd,info,blck)
use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_silu_bld
implicit none
! Arguments
type(psb_sspmat_type), intent(in), target :: a
type(mld_sbaseprec_type), intent(inout) :: p
character, intent(in) :: upd
integer, intent(out) :: info
type(psb_sspmat_type), intent(in), optional :: blck
! Local Variables
integer :: i, nztota, err_act, n_row, nrow_a
character :: trans, unitd
integer :: debug_level, debug_unit
integer :: ictxt,np,me
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=psb_success_
name='mld_silu_bld'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(p%desc_data)
call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' start'
trans = 'N'
unitd = 'U'
!
! Check the memory available to hold the incomplete L and U factors
! and allocate it if needed
!
if (allocated(p%av)) then
if (size(p%av) < mld_bp_ilu_avsz_) then
do i=1,size(p%av)
call psb_sp_free(p%av(i),info)
if (info /= psb_success_) then
! Actually, we don't care here about this. Just let it go.
! return
end if
enddo
deallocate(p%av,stat=info)
endif
end if
if (.not.allocated(p%av)) then
allocate(p%av(mld_max_avsz_),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
endif
nrow_a = psb_sp_get_nrows(a)
nztota = psb_sp_get_nnzeros(a)
if (present(blck)) then
nztota = nztota + psb_sp_get_nnzeros(blck)
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': out get_nnzeros',nztota,a%m,a%k,nrow_a
n_row = p%desc_data%matrix_data(psb_n_row_)
p%av(mld_l_pr_)%m = n_row
p%av(mld_l_pr_)%k = n_row
p%av(mld_u_pr_)%m = n_row
p%av(mld_u_pr_)%k = n_row
call psb_sp_all(n_row,n_row,p%av(mld_l_pr_),nztota,info)
if (info == psb_success_) call psb_sp_all(n_row,n_row,p%av(mld_u_pr_),nztota,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (allocated(p%d)) then
if (size(p%d) < n_row) then
deallocate(p%d)
endif
endif
if (.not.allocated(p%d)) then
allocate(p%d(n_row),stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
endif
select case(p%iprcparm(mld_sub_solve_))
case (mld_ilu_t_)
!
! ILU(k,t)
!
select case(p%iprcparm(mld_sub_fillin_))
case(:-1)
! Error: fill-in <= -1
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,p%iprcparm(mld_sub_fillin_),0,0,0/))
goto 9999
case(0:)
! Fill-in >= 0
call mld_ilut_fact(p%iprcparm(mld_sub_fillin_),p%rprcparm(mld_sub_iluthrs_),&
& a, p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck)
end select
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_ilut_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(mld_ilu_n_,mld_milu_n_)
!
! ILU(k) and MILU(k)
!
select case(p%iprcparm(mld_sub_fillin_))
case(:-1)
! Error: fill-in <= -1
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=(/3,p%iprcparm(mld_sub_fillin_),0,0,0/))
goto 9999
case(0)
! Fill-in 0
! Separate implementation of ILU(0) for better performance.
! There seems to be a problem with the separate implementation of MILU(0),
! contained into mld_ilu0_fact. This must be investigated. For the time being,
! resort to the implementation of MILU(k) with k=0.
if (p%iprcparm(mld_sub_solve_) == mld_ilu_n_) then
call mld_ilu0_fact(p%iprcparm(mld_sub_solve_),a,p%av(mld_l_pr_),p%av(mld_u_pr_),&
& p%d,info,blck=blck)
else
call mld_iluk_fact(p%iprcparm(mld_sub_fillin_),p%iprcparm(mld_sub_solve_),&
& a,p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck)
endif
case(1:)
! Fill-in >= 1
! The same routine implements both ILU(k) and MILU(k)
call mld_iluk_fact(p%iprcparm(mld_sub_fillin_),p%iprcparm(mld_sub_solve_),&
& a,p%av(mld_l_pr_),p%av(mld_u_pr_),p%d,info,blck=blck)
end select
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='mld_iluk_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case default
! If we end up here, something was wrong up in the call chain.
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end select
if (psb_sp_getifld(psb_upd_,p%av(mld_u_pr_),info) /= psb_upd_perm_) then
call psb_sp_trim(p%av(mld_u_pr_),info)
endif
if (psb_sp_getifld(psb_upd_,p%av(mld_l_pr_),info) /= psb_upd_perm_) then
call psb_sp_trim(p%av(mld_l_pr_),info)
endif
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' end'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_silu_bld

256
mlprec/mld_siluk_fact.f90
Unescape Escape View File

@ -99,7 +99,7 @@
subroutine mld_siluk_fact(fill_in,ialg,a,l,u,d,info,blck) subroutine mld_siluk_fact(fill_in,ialg,a,l,u,d,info,blck)
use psb_sparse_mod use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_siluk_fact use mld_inner_mod!, mld_protect_name => mld_siluk_fact
implicit none implicit none
@ -114,6 +114,7 @@ subroutine mld_siluk_fact(fill_in,ialg,a,l,u,d,info,blck)
integer :: l1, l2, m, err_act integer :: l1, l2, m, err_act
type(psb_sspmat_type), pointer :: blck_ type(psb_sspmat_type), pointer :: blck_
type(psb_s_csr_sparse_mat) :: ll, uu
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='mld_siluk_fact' name='mld_siluk_fact'
@ -127,26 +128,32 @@ subroutine mld_siluk_fact(fill_in,ialg,a,l,u,d,info,blck)
blck_ => blck blck_ => blck
else else
allocate(blck_,stat=info) allocate(blck_,stat=info)
if (info /= psb_success_) then if (info == psb_success_) call blck_%csall(0,0,info,1)
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
call psb_sp_all(0,0,blck_,1,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_sp_all' ch_err='csall'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
endif endif
m = a%get_nrows() + blck_%get_nrows()
if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.&
& (m > size(d)) ) then
write(0,*) 'Wrong allocation status for L,D,U? ',&
& l%get_nrows(),size(d),u%get_nrows()
info = -1
return
end if
call l%mv_to(ll)
call u%mv_to(uu)
! !
! Compute the ILU(k) or the MILU(k) factorization, depending on ialg ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg
! !
call mld_siluk_factint(fill_in,ialg,m,a,blck_,& call mld_siluk_factint(fill_in,ialg,a,blck_,&
& d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mld_siluk_factint' ch_err='mld_siluk_factint'
@ -157,33 +164,32 @@ subroutine mld_siluk_fact(fill_in,ialg,a,l,u,d,info,blck)
! !
! Store information on the L and U sparse matrices ! Store information on the L and U sparse matrices
! !
l%infoa(1) = l1 call l%mv_from(ll)
l%fida = 'CSR' call l%set_triangle()
l%descra = 'TLU' call l%set_unit()
u%infoa(1) = l2 call l%set_lower()
u%fida = 'CSR' call u%mv_from(uu)
u%descra = 'TUU' call u%set_triangle()
l%m = m call u%set_unit()
l%k = m call u%set_upper()
u%m = m
u%k = m
! !
! Nullify the pointer / deallocate the memory ! Nullify pointer / deallocate memory
! !
if (present(blck)) then if (present(blck)) then
blck_ => null() blck_ => null()
else else
call psb_sp_free(blck_,info) call blck_%free()
if (info /= psb_success_) then deallocate(blck_,stat=info)
info=psb_err_from_subroutine_ if(info.ne.0) then
ch_err='psb_sp_free' info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err=ch_err) ch_err='psb_sp_free'
goto 9999 call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if end if
deallocate(blck_)
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -248,43 +254,43 @@ contains
! lia2 - integer, dimension(:), input/output. ! lia2 - integer, dimension(:), input/output.
! The indices identifying the first nonzero entry of each row ! The indices identifying the first nonzero entry of each row
! of the L factor in laspk, according to the CSR storage format. ! of the L factor in laspk, according to the CSR storage format.
! uaspk - real(psb_spk_), dimension(:), input/output. ! uval - real(psb_spk_), dimension(:), input/output.
! The U factor in the incomplete factorization. ! The U factor in the incomplete factorization.
! The entries of U are stored according to the CSR format. ! The entries of U are stored according to the CSR format.
! uia1 - integer, dimension(:), input/output. ! uja - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the U factor, ! The column indices of the nonzero entries of the U factor,
! according to the CSR storage format. ! according to the CSR storage format.
! uia2 - integer, dimension(:), input/output. ! uirp - integer, dimension(:), input/output.
! The indices identifying the first nonzero entry of each row ! The indices identifying the first nonzero entry of each row
! of the U factor in uaspk, according to the CSR storage format. ! of the U factor in uval, according to the CSR storage format.
! l1 - integer, output ! l1 - integer, output
! The number of nonzero entries in laspk. ! The number of nonzero entries in laspk.
! l2 - integer, output ! l2 - integer, output
! The number of nonzero entries in uaspk. ! The number of nonzero entries in uval.
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_siluk_factint(fill_in,ialg,m,a,b,& subroutine mld_siluk_factint(fill_in,ialg,a,b,&
& d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info) & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info)
use psb_sparse_mod use psb_sparse_mod
implicit none implicit none
! Arguments ! Arguments
integer, intent(in) :: fill_in, ialg integer, intent(in) :: fill_in, ialg
type(psb_sspmat_type), intent(in) :: a,b type(psb_sspmat_type),intent(in) :: a,b
integer, intent(inout) :: m,l1,l2,info integer,intent(inout) :: l1,l2,info
integer, allocatable, intent(inout) :: lia1(:),lia2(:),uia1(:),uia2(:) integer, allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:)
real(psb_spk_), allocatable, intent(inout) :: laspk(:),uaspk(:) real(psb_spk_), allocatable, intent(inout) :: lval(:),uval(:)
real(psb_spk_), intent(inout) :: d(:) real(psb_spk_), intent(inout) :: d(:)
! Local variables ! Local variables
integer :: ma,mb,i, ktrw,err_act,nidx integer :: ma,mb,i, ktrw,err_act,nidx, m
integer, allocatable :: uplevs(:), rowlevs(:),idxs(:) integer, allocatable :: uplevs(:), rowlevs(:),idxs(:)
real(psb_spk_), allocatable :: row(:) real(psb_spk_), allocatable :: row(:)
type(psb_int_heap) :: heap type(psb_int_heap) :: heap
type(psb_sspmat_type) :: trw type(psb_s_coo_sparse_mat) :: trw
character(len=20), parameter :: name='mld_siluk_factint' character(len=20), parameter :: name='mld_siluk_factint'
character(len=20) :: ch_err character(len=20) :: ch_err
@ -292,6 +298,7 @@ contains
info=psb_success_ info=psb_success_
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
select case(ialg) select case(ialg)
case(mld_ilu_n_,mld_milu_n_) case(mld_ilu_n_,mld_milu_n_)
! Ok ! Ok
@ -306,16 +313,17 @@ contains
goto 9999 goto 9999
end if end if
ma = a%m ma = a%get_nrows()
mb = b%m mb = b%get_nrows()
m = ma+mb m = ma+mb
! !
! Allocate a temporary buffer for the iluk_copyin function ! Allocate a temporary buffer for the iluk_copyin function
! !
call psb_sp_all(0,0,trw,1,info)
if (info == psb_success_) call psb_ensure_size(m+1,lia2,info) call trw%allocate(0,0,1)
if (info == psb_success_) call psb_ensure_size(m+1,uia2,info) if (info == psb_success_) call psb_ensure_size(m+1,lirp,info)
if (info == psb_success_) call psb_ensure_size(m+1,uirp,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
@ -325,14 +333,14 @@ contains
l1=0 l1=0
l2=0 l2=0
lia2(1) = 1 lirp(1) = 1
uia2(1) = 1 uirp(1) = 1
! !
! Allocate memory to hold the entries of a row and the corresponding ! Allocate memory to hold the entries of a row and the corresponding
! fill levels ! fill levels
! !
allocate(uplevs(size(uaspk)),rowlevs(m),row(m),stat=info) allocate(uplevs(size(uval)),rowlevs(m),row(m),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate') call psb_errpush(info,name,a_err='Allocate')
@ -375,12 +383,12 @@ contains
! do not have a lowlevs variable. ! do not have a lowlevs variable.
! !
if (info == psb_success_) call iluk_fact(fill_in,i,row,rowlevs,heap,& if (info == psb_success_) call iluk_fact(fill_in,i,row,rowlevs,heap,&
& d,uia1,uia2,uaspk,uplevs,nidx,idxs,info) & d,uja,uirp,uval,uplevs,nidx,idxs,info)
! !
! Copy the row into laspk/d(i)/uaspk ! Copy the row into lval/d(i)/uval
! !
if (info == psb_success_) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& if (info == psb_success_) call iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,&
& l1,l2,lia1,lia2,laspk,d,uia1,uia2,uaspk,uplevs,info) & l1,l2,lja,lirp,lval,d,uja,uirp,uval,uplevs,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_internal_error_ info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Copy/factor loop') call psb_errpush(info,name,a_err='Copy/factor loop')
@ -397,7 +405,7 @@ contains
call psb_errpush(info,name,a_err='Deallocate') call psb_errpush(info,name,a_err='Deallocate')
goto 9999 goto 9999
end if end if
if (info == psb_success_) call psb_sp_free(trw,info) if (info == psb_success_) call trw%free()
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_sp_free' ch_err='psb_sp_free'
@ -489,7 +497,7 @@ contains
! Arguments ! Arguments
type(psb_sspmat_type), intent(in) :: a type(psb_sspmat_type), intent(in) :: a
type(psb_sspmat_type), intent(inout) :: trw type(psb_s_coo_sparse_mat), intent(inout) :: trw
integer, intent(in) :: i,m,jmin,jmax integer, intent(in) :: i,m,jmin,jmax
integer, intent(inout) :: ktrw,info integer, intent(inout) :: ktrw,info
integer, intent(inout) :: rowlevs(:) integer, intent(inout) :: rowlevs(:)
@ -497,8 +505,8 @@ contains
type(psb_int_heap), intent(inout) :: heap type(psb_int_heap), intent(inout) :: heap
! Local variables ! Local variables
integer :: k,j,irb,err_act integer :: k,j,irb,err_act,nz
integer, parameter :: nrb=16 integer, parameter :: nrb=40
character(len=20), parameter :: name='iluk_copyin' character(len=20), parameter :: name='iluk_copyin'
character(len=20) :: ch_err character(len=20) :: ch_err
@ -507,22 +515,22 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
call psb_init_heap(heap,info) call psb_init_heap(heap,info)
if (psb_toupper(a%fida) == 'CSR') then select type (aa=> a%a)
type is (psb_s_csr_sparse_mat)
! !
! Take a fast shortcut if the matrix is stored in CSR format ! Take a fast shortcut if the matrix is stored in CSR format
! !
do j = a%ia2(i), a%ia2(i+1) - 1 do j = aa%irp(i), aa%irp(i+1) - 1
k = a%ia1(j) k = aa%ja(j)
if ((jmin<=k).and.(k<=jmax)) then if ((jmin<=k).and.(k<=jmax)) then
row(k) = a%aspk(j) row(k) = aa%val(j)
rowlevs(k) = 0 rowlevs(k) = 0
call psb_insert_heap(k,heap,info) call psb_insert_heap(k,heap,info)
end if end if
end do end do
else class default
! !
! Otherwise use psb_sp_getblk, slower but able (in principle) of ! Otherwise use psb_sp_getblk, slower but able (in principle) of
@ -534,7 +542,7 @@ contains
if ((mod(i,nrb) == 1).or.(nrb == 1)) then if ((mod(i,nrb) == 1).or.(nrb == 1)) then
irb = min(m-i+1,nrb) irb = min(m-i+1,nrb)
call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1) call aa%csget(i,i+irb-1,trw,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_sp_getblk' ch_err='psb_sp_getblk'
@ -543,19 +551,19 @@ contains
end if end if
ktrw=1 ktrw=1
end if end if
nz = trw%get_nzeros()
do do
if (ktrw > trw%infoa(psb_nnz_)) exit if (ktrw > nz) exit
if (trw%ia1(ktrw) > i) exit if (trw%ia(ktrw) > i) exit
k = trw%ia2(ktrw) k = trw%ja(ktrw)
if ((jmin<=k).and.(k<=jmax)) then if ((jmin<=k).and.(k<=jmax)) then
row(k) = trw%aspk(ktrw) row(k) = trw%val(ktrw)
rowlevs(k) = 0 rowlevs(k) = 0
call psb_insert_heap(k,heap,info) call psb_insert_heap(k,heap,info)
end if end if
ktrw = ktrw + 1 ktrw = ktrw + 1
enddo enddo
end if end select
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -611,17 +619,17 @@ contains
! d - real(psb_spk_), input. ! d - real(psb_spk_), input.
! The inverse of the diagonal entries of the part of the U factor ! The inverse of the diagonal entries of the part of the U factor
! above the current row (see iluk_copyout). ! above the current row (see iluk_copyout).
! uia1 - integer, dimension(:), input. ! uja - integer, dimension(:), input.
! The column indices of the nonzero entries of the part of the U ! The column indices of the nonzero entries of the part of the U
! factor above the current row, stored in uaspk row by row (see ! factor above the current row, stored in uval row by row (see
! iluk_copyout, called by mld_siluk_factint), according to the CSR ! iluk_copyout, called by mld_siluk_factint), according to the CSR
! storage format. ! storage format.
! uia2 - integer, dimension(:), input. ! uirp - integer, dimension(:), input.
! The indices identifying the first nonzero entry of each row of ! The indices identifying the first nonzero entry of each row of
! the U factor above the current row, stored in uaspk row by row ! the U factor above the current row, stored in uval row by row
! (see iluk_copyout, called by mld_siluk_factint), according to ! (see iluk_copyout, called by mld_siluk_factint), according to
! the CSR storage format. ! the CSR storage format.
! uaspk - real(psb_spk_), dimension(:), input. ! uval - real(psb_spk_), dimension(:), input.
! The entries of the U factor above the current row (except the ! The entries of the U factor above the current row (except the
! diagonal ones), stored according to the CSR format. ! diagonal ones), stored according to the CSR format.
! uplevs - integer, dimension(:), input. ! uplevs - integer, dimension(:), input.
@ -638,7 +646,7 @@ contains
! Note: this argument is intent(inout) and not only intent(out) ! Note: this argument is intent(inout) and not only intent(out)
! to retain its allocation, done by this routine. ! to retain its allocation, done by this routine.
! !
subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uia1,uia2,uaspk,uplevs,nidx,idxs,info) subroutine iluk_fact(fill_in,i,row,rowlevs,heap,d,uja,uirp,uval,uplevs,nidx,idxs,info)
use psb_sparse_mod use psb_sparse_mod
@ -650,8 +658,8 @@ contains
integer, intent(inout) :: nidx,info integer, intent(inout) :: nidx,info
integer, intent(inout) :: rowlevs(:) integer, intent(inout) :: rowlevs(:)
integer, allocatable, intent(inout) :: idxs(:) integer, allocatable, intent(inout) :: idxs(:)
integer, intent(inout) :: uia1(:),uia2(:),uplevs(:) integer, intent(inout) :: uja(:),uirp(:),uplevs(:)
real(psb_spk_), intent(inout) :: row(:), uaspk(:),d(:) real(psb_spk_), intent(inout) :: row(:), uval(:),d(:)
! Local variables ! Local variables
integer :: k,j,lrwk,jj,lastk, iret integer :: k,j,lrwk,jj,lastk, iret
@ -695,8 +703,8 @@ contains
row(k) = row(k) * d(k) ! d(k) == 1/a(k,k) row(k) = row(k) * d(k) ! d(k) == 1/a(k,k)
lrwk = rowlevs(k) lrwk = rowlevs(k)
do jj=uia2(k),uia2(k+1)-1 do jj=uirp(k),uirp(k+1)-1
j = uia1(jj) j = uja(jj)
if (j<=k) then if (j<=k) then
info = -i info = -i
return return
@ -716,7 +724,7 @@ contains
! !
! Update row(j) and the corresponding fill level ! Update row(j) and the corresponding fill level
! !
row(j) = row(j) - rwk * uaspk(jj) row(j) = row(j) - rwk * uval(jj)
rowlevs(j) = min(rowlevs(j),lrwk+uplevs(jj)+1) rowlevs(j) = min(rowlevs(j),lrwk+uplevs(jj)+1)
end do end do
@ -731,19 +739,19 @@ contains
! Note: internal subroutine of mld_siluk_fact ! Note: internal subroutine of mld_siluk_fact
! !
! This routine copies a matrix row, computed by iluk_fact by applying an ! This routine copies a matrix row, computed by iluk_fact by applying an
! elimination step of the ILU(k) factorization, into the arrays laspk, uaspk, ! elimination step of the ILU(k) factorization, into the arrays lval, uval,
! d, corresponding to the L factor, the U factor and the diagonal of U, ! d, corresponding to the L factor, the U factor and the diagonal of U,
! respectively. ! respectively.
! !
! Note that ! Note that
! - the part of the row stored into uaspk is scaled by the corresponding diagonal ! - the part of the row stored into uval is scaled by the corresponding diagonal
! entry, according to the LDU form of the incomplete factorization; ! entry, according to the LDU form of the incomplete factorization;
! - the inverse of the diagonal entries of U is actually stored into d; this is ! - the inverse of the diagonal entries of U is actually stored into d; this is
! then managed in the solve stage associated to the ILU(k)/MILU(k) factorization; ! then managed in the solve stage associated to the ILU(k)/MILU(k) factorization;
! - if the MILU(k) factorization has been required (ialg == mld_milu_n_), the ! - if the MILU(k) factorization has been required (ialg == mld_milu_n_), the
! row entries discarded because their fill levels are too high are added to ! row entries discarded because their fill levels are too high are added to
! the diagonal entry of the row; ! the diagonal entry of the row;
! - the row entries are stored in laspk and uaspk according to the CSR format; ! - the row entries are stored in lval and uval according to the CSR format;
! - the arrays row and rowlevs are re-initialized for future use in mld_iluk_fact ! - the arrays row and rowlevs are re-initialized for future use in mld_iluk_fact
! (see also iluk_copyin and iluk_fact). ! (see also iluk_copyin and iluk_fact).
! !
@ -781,32 +789,32 @@ contains
! examined during the elimination step carried out by the routine ! examined during the elimination step carried out by the routine
! iluk_fact. ! iluk_fact.
! l1 - integer, input/output. ! l1 - integer, input/output.
! Pointer to the last occupied entry of laspk. ! Pointer to the last occupied entry of lval.
! l2 - integer, input/output. ! l2 - integer, input/output.
! Pointer to the last occupied entry of uaspk. ! Pointer to the last occupied entry of uval.
! lia1 - integer, dimension(:), input/output. ! lja - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the L factor, ! The column indices of the nonzero entries of the L factor,
! copied in laspk row by row (see mld_siluk_factint), according ! copied in lval row by row (see mld_siluk_factint), according
! to the CSR storage format. ! to the CSR storage format.
! lia2 - integer, dimension(:), input/output. ! lirp - integer, dimension(:), input/output.
! The indices identifying the first nonzero entry of each row ! The indices identifying the first nonzero entry of each row
! of the L factor, copied in laspk row by row (see ! of the L factor, copied in lval row by row (see
! mld_siluk_factint), according to the CSR storage format. ! mld_siluk_factint), according to the CSR storage format.
! laspk - real(psb_spk_), dimension(:), input/output. ! lval - real(psb_spk_), dimension(:), input/output.
! The array where the entries of the row corresponding to the ! The array where the entries of the row corresponding to the
! L factor are copied. ! L factor are copied.
! d - real(psb_spk_), dimension(:), input/output. ! d - real(psb_spk_), dimension(:), input/output.
! The array where the inverse of the diagonal entry of the ! The array where the inverse of the diagonal entry of the
! row is copied (only d(i) is used by the routine). ! row is copied (only d(i) is used by the routine).
! uia1 - integer, dimension(:), input/output. ! uja - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the U factor ! The column indices of the nonzero entries of the U factor
! copied in uaspk row by row (see mld_siluk_factint), according ! copied in uval row by row (see mld_siluk_factint), according
! to the CSR storage format. ! to the CSR storage format.
! uia2 - integer, dimension(:), input/output. ! uirp - integer, dimension(:), input/output.
! The indices identifying the first nonzero entry of each row ! The indices identifying the first nonzero entry of each row
! of the U factor copied in uaspk row by row (see ! of the U factor copied in uval row by row (see
! mld_silu_fctint), according to the CSR storage format. ! mld_silu_fctint), according to the CSR storage format.
! uaspk - real(psb_spk_), dimension(:), input/output. ! uval - real(psb_spk_), dimension(:), input/output.
! The array where the entries of the row corresponding to the ! The array where the entries of the row corresponding to the
! U factor are copied. ! U factor are copied.
! uplevs - integer, dimension(:), input. ! uplevs - integer, dimension(:), input.
@ -814,18 +822,18 @@ contains
! U factor above the current row. ! U factor above the current row.
! !
subroutine iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,& subroutine iluk_copyout(fill_in,ialg,i,m,row,rowlevs,nidx,idxs,&
& l1,l2,lia1,lia2,laspk,d,uia1,uia2,uaspk,uplevs,info) & l1,l2,lja,lirp,lval,d,uja,uirp,uval,uplevs,info)
use psb_sparse_mod use psb_sparse_mod
implicit none implicit none
! Arguments ! Arguments
integer, intent(in) :: fill_in, ialg, i, m, nidx integer, intent(in) :: fill_in, ialg, i, m, nidx
integer, intent(inout) :: l1, l2, info integer, intent(inout) :: l1, l2, info
integer, intent(inout) :: rowlevs(:), idxs(:) integer, intent(inout) :: rowlevs(:), idxs(:)
integer, allocatable, intent(inout) :: uia1(:), uia2(:), lia1(:), lia2(:),uplevs(:) integer, allocatable, intent(inout) :: uja(:), uirp(:), lja(:), lirp(:),uplevs(:)
real(psb_spk_), allocatable, intent(inout) :: uaspk(:), laspk(:) real(psb_spk_), allocatable, intent(inout) :: uval(:), lval(:)
real(psb_spk_), intent(inout) :: row(:), d(:) real(psb_spk_), intent(inout) :: row(:), d(:)
! Local variables ! Local variables
@ -849,21 +857,21 @@ contains
! !
if (rowlevs(j) <= fill_in) then if (rowlevs(j) <= fill_in) then
l1 = l1 + 1 l1 = l1 + 1
if (size(laspk) < l1) then if (size(lval) < l1) then
! !
! Figure out a good reallocation size! ! Figure out a good reallocation size!
! !
isz = (max((l1/i)*m,int(1.2*l1),l1+100)) isz = (max((l1/i)*m,int(1.2*l1),l1+100))
call psb_realloc(isz,laspk,info) call psb_realloc(isz,lval,info)
if (info == psb_success_) call psb_realloc(isz,lia1,info) if (info == psb_success_) call psb_realloc(isz,lja,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate') call psb_errpush(info,name,a_err='Allocate')
goto 9999 goto 9999
end if end if
end if end if
lia1(l1) = j lja(l1) = j
laspk(l1) = row(j) lval(l1) = row(j)
else if (ialg == mld_milu_n_) then else if (ialg == mld_milu_n_) then
! !
! MILU(k): add discarded entries to the diagonal one ! MILU(k): add discarded entries to the diagonal one
@ -891,13 +899,13 @@ contains
! !
if (rowlevs(j) <= fill_in) then if (rowlevs(j) <= fill_in) then
l2 = l2 + 1 l2 = l2 + 1
if (size(uaspk) < l2) then if (size(uval) < l2) then
! !
! Figure out a good reallocation size! ! Figure out a good reallocation size!
! !
isz = max((l2/i)*m,int(1.2*l2),l2+100) isz = max((l2/i)*m,int(1.2*l2),l2+100)
call psb_realloc(isz,uaspk,info) call psb_realloc(isz,uval,info)
if (info == psb_success_) call psb_realloc(isz,uia1,info) if (info == psb_success_) call psb_realloc(isz,uja,info)
if (info == psb_success_) call psb_realloc(isz,uplevs,info,pad=(m+1)) if (info == psb_success_) call psb_realloc(isz,uplevs,info,pad=(m+1))
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
@ -905,8 +913,8 @@ contains
goto 9999 goto 9999
end if end if
end if end if
uia1(l2) = j uja(l2) = j
uaspk(l2) = row(j) uval(l2) = row(j)
uplevs(l2) = rowlevs(j) uplevs(l2) = rowlevs(j)
else if (ialg == mld_milu_n_) then else if (ialg == mld_milu_n_) then
! !
@ -917,17 +925,17 @@ contains
! !
! Re-initialize row(j) and rowlevs(j) ! Re-initialize row(j) and rowlevs(j)
! !
row(j) = szero row(j) = szero
rowlevs(j) = -(m+1) rowlevs(j) = -(m+1)
end if end if
end do end do
! !
! Store the pointers to the first non occupied entry of in ! Store the pointers to the first non occupied entry of in
! laspk and uaspk ! lval and uval
! !
lia2(i+1) = l1 + 1 lirp(i+1) = l1 + 1
uia2(i+1) = l2 + 1 uirp(i+1) = l2 + 1
! !
! Check the pivot size ! Check the pivot size
@ -951,8 +959,8 @@ contains
! !
! Scale the upper part ! Scale the upper part
! !
do j=uia2(i), uia2(i+1)-1 do j=uirp(i), uirp(i+1)-1
uaspk(j) = d(i)*uaspk(j) uval(j) = d(i)*uval(j)
end do end do
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)

299
mlprec/mld_silut_fact.f90
Unescape Escape View File

@ -95,7 +95,7 @@
subroutine mld_silut_fact(fill_in,thres,a,l,u,d,info,blck) subroutine mld_silut_fact(fill_in,thres,a,l,u,d,info,blck)
use psb_sparse_mod use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_silut_fact use mld_inner_mod!, mld_protect_name => mld_silut_fact
implicit none implicit none
@ -105,13 +105,13 @@ subroutine mld_silut_fact(fill_in,thres,a,l,u,d,info,blck)
integer, intent(out) :: info integer, intent(out) :: info
type(psb_sspmat_type),intent(in) :: a type(psb_sspmat_type),intent(in) :: a
type(psb_sspmat_type),intent(inout) :: l,u type(psb_sspmat_type),intent(inout) :: l,u
real(psb_spk_), intent(inout) :: d(:)
type(psb_sspmat_type),intent(in), optional, target :: blck type(psb_sspmat_type),intent(in), optional, target :: blck
real(psb_spk_), intent(inout) :: d(:)
! Local Variables ! Local Variables
integer :: l1, l2, m, err_act integer :: l1, l2, m, err_act
type(psb_sspmat_type), pointer :: blck_ type(psb_sspmat_type), pointer :: blck_
type(psb_s_csr_sparse_mat) :: ll, uu
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='mld_silut_fact' name='mld_silut_fact'
@ -130,26 +130,32 @@ subroutine mld_silut_fact(fill_in,thres,a,l,u,d,info,blck)
blck_ => blck blck_ => blck
else else
allocate(blck_,stat=info) allocate(blck_,stat=info)
if (info /= psb_success_) then if (info == psb_success_) call blck_%csall(0,0,info,1)
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
call psb_sp_all(0,0,blck_,1,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_sp_all' ch_err='csall'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
endif endif
m = a%get_nrows() + blck_%get_nrows()
if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.&
& (m > size(d)) ) then
write(0,*) 'Wrong allocation status for L,D,U? ',&
& l%get_nrows(),size(d),u%get_nrows()
info = -1
return
end if
call l%mv_to(ll)
call u%mv_to(uu)
! !
! Compute the ILU(k,t) factorization ! Compute the ILU(k,t) factorization
! !
call mld_silut_factint(fill_in,thres,m,a,blck_,& call mld_silut_factint(fill_in,thres,a,blck_,&
& d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mld_silut_factint' ch_err='mld_silut_factint'
@ -160,31 +166,29 @@ subroutine mld_silut_fact(fill_in,thres,a,l,u,d,info,blck)
! !
! Store information on the L and U sparse matrices ! Store information on the L and U sparse matrices
! !
l%infoa(1) = l1 call l%mv_from(ll)
l%fida = 'CSR' call l%set_triangle()
l%descra = 'TLU' call l%set_unit()
u%infoa(1) = l2 call l%set_lower()
u%fida = 'CSR' call u%mv_from(uu)
u%descra = 'TUU' call u%set_triangle()
l%m = m call u%set_unit()
l%k = m call u%set_upper()
u%m = m
u%k = m
! !
! Nullify the pointer / deallocate the memory ! Nullify pointer / deallocate memory
! !
if (present(blck)) then if (present(blck)) then
blck_ => null() blck_ => null()
else else
call psb_sp_free(blck_,info) call blck_%free()
if (info /= psb_success_) then deallocate(blck_,stat=info)
info=psb_err_from_subroutine_ if(info.ne.0) then
ch_err='psb_sp_free' info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err=ch_err) ch_err='psb_sp_free'
goto 9999 call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if end if
deallocate(blck_)
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -241,32 +245,32 @@ contains
! d - real(psb_spk_), dimension(:), output. ! d - real(psb_spk_), dimension(:), output.
! The inverse of the diagonal entries of the U factor in the incomplete ! The inverse of the diagonal entries of the U factor in the incomplete
! factorization. ! factorization.
! laspk - real(psb_spk_), dimension(:), input/output. ! lval - real(psb_spk_), dimension(:), input/output.
! The L factor in the incomplete factorization. ! The L factor in the incomplete factorization.
! lia1 - integer, dimension(:), input/output. ! lia1 - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the L factor, ! The column indices of the nonzero entries of the L factor,
! according to the CSR storage format. ! according to the CSR storage format.
! lia2 - integer, dimension(:), input/output. ! lirp - integer, dimension(:), input/output.
! The indices identifying the first nonzero entry of each row ! The indices identifying the first nonzero entry of each row
! of the L factor in laspk, according to the CSR storage format. ! of the L factor in lval, according to the CSR storage format.
! uaspk - real(psb_spk_), dimension(:), input/output. ! uval - real(psb_spk_), dimension(:), input/output.
! The U factor in the incomplete factorization. ! The U factor in the incomplete factorization.
! The entries of U are stored according to the CSR format. ! The entries of U are stored according to the CSR format.
! uia1 - integer, dimension(:), input/output. ! uja - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the U factor, ! The column indices of the nonzero entries of the U factor,
! according to the CSR storage format. ! according to the CSR storage format.
! uia2 - integer, dimension(:), input/output. ! uirp - integer, dimension(:), input/output.
! The indices identifying the first nonzero entry of each row ! The indices identifying the first nonzero entry of each row
! of the U factor in uaspk, according to the CSR storage format. ! of the U factor in uval, according to the CSR storage format.
! l1 - integer, output ! l1 - integer, output
! The number of nonzero entries in laspk. ! The number of nonzero entries in lval.
! l2 - integer, output ! l2 - integer, output
! The number of nonzero entries in uaspk. ! The number of nonzero entries in uval.
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_silut_factint(fill_in,thres,m,a,b,& subroutine mld_silut_factint(fill_in,thres,a,b,&
& d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info) & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info)
use psb_sparse_mod use psb_sparse_mod
@ -275,19 +279,19 @@ contains
! Arguments ! Arguments
integer, intent(in) :: fill_in integer, intent(in) :: fill_in
real(psb_spk_), intent(in) :: thres real(psb_spk_), intent(in) :: thres
type(psb_sspmat_type), intent(in) :: a,b type(psb_sspmat_type),intent(in) :: a,b
integer, intent(inout) :: m,l1,l2,info integer,intent(inout) :: l1,l2,info
integer, allocatable, intent(inout) :: lia1(:),lia2(:),uia1(:),uia2(:) integer, allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:)
real(psb_spk_), allocatable, intent(inout) :: laspk(:),uaspk(:) real(psb_spk_), allocatable, intent(inout) :: lval(:),uval(:)
real(psb_spk_), intent(inout) :: d(:) real(psb_spk_), intent(inout) :: d(:)
! Local Variables ! Local Variables
integer :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb integer :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb, m
real(psb_spk_) :: nrmi real(psb_spk_) :: nrmi
integer, allocatable :: idxs(:) integer, allocatable :: idxs(:)
real(psb_spk_), allocatable :: row(:) real(psb_spk_), allocatable :: row(:)
type(psb_int_heap) :: heap type(psb_int_heap) :: heap
type(psb_sspmat_type) :: trw type(psb_s_coo_sparse_mat) :: trw
character(len=20), parameter :: name='mld_silut_factint' character(len=20), parameter :: name='mld_silut_factint'
character(len=20) :: ch_err character(len=20) :: ch_err
@ -296,16 +300,16 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ma = a%m ma = a%get_nrows()
mb = b%m mb = b%get_nrows()
m = ma+mb m = ma+mb
! !
! Allocate a temporary buffer for the ilut_copyin function ! Allocate a temporary buffer for the ilut_copyin function
! !
call psb_sp_all(0,0,trw,1,info) call trw%allocate(0,0,1)
if (info == psb_success_) call psb_ensure_size(m+1,lia2,info) if (info == psb_success_) call psb_ensure_size(m+1,lirp,info)
if (info == psb_success_) call psb_ensure_size(m+1,uia2,info) if (info == psb_success_) call psb_ensure_size(m+1,uirp,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
@ -315,8 +319,8 @@ contains
l1=0 l1=0
l2=0 l2=0
lia2(1) = 1 lirp(1) = 1
uia2(1) = 1 uirp(1) = 1
! !
! Allocate memory to hold the entries of a row ! Allocate memory to hold the entries of a row
@ -354,12 +358,12 @@ contains
! Do an elimination step on current row ! Do an elimination step on current row
! !
if (info == psb_success_) call ilut_fact(thres,i,nrmi,row,heap,& if (info == psb_success_) call ilut_fact(thres,i,nrmi,row,heap,&
& d,uia1,uia2,uaspk,nidx,idxs,info) & d,uja,uirp,uval,nidx,idxs,info)
! !
! Copy the row into laspk/d(i)/uaspk ! Copy the row into lval/d(i)/uval
! !
if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row,nidx,idxs,& if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row,nidx,idxs,&
& l1,l2,lia1,lia2,laspk,d,uia1,uia2,uaspk,info) & l1,l2,lja,lirp,lval,d,uja,uirp,uval,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_internal_error_ info=psb_err_internal_error_
@ -378,7 +382,7 @@ contains
call psb_errpush(info,name,a_err='Deallocate') call psb_errpush(info,name,a_err='Deallocate')
goto 9999 goto 9999
end if end if
if (info == psb_success_) call psb_sp_free(trw,info) if (info == psb_success_) call trw%free()
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_sp_free' ch_err='psb_sp_free'
@ -482,17 +486,17 @@ contains
subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,nrmi,row,heap,ktrw,trw,info) subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,nrmi,row,heap,ktrw,trw,info)
use psb_sparse_mod use psb_sparse_mod
implicit none implicit none
type(psb_sspmat_type), intent(in) :: a type(psb_sspmat_type), intent(in) :: a
type(psb_sspmat_type), intent(inout) :: trw type(psb_s_coo_sparse_mat), intent(inout) :: trw
integer, intent(in) :: i, m,jmin,jmax,jd integer, intent(in) :: i, m,jmin,jmax,jd
integer, intent(inout) :: ktrw,nlw,nup,jmaxup,info integer, intent(inout) :: ktrw,nlw,nup,jmaxup,info
real(psb_spk_), intent(inout) :: nrmi,row(:) real(psb_spk_), intent(inout) :: nrmi,row(:)
type(psb_int_heap), intent(inout) :: heap type(psb_int_heap), intent(inout) :: heap
integer :: k,j,irb,kin,nz integer :: k,j,irb,kin,nz
integer, parameter :: nrb=16 integer, parameter :: nrb=40
real(psb_spk_) :: dmaxup real(psb_spk_) :: dmaxup
real(psb_spk_), external :: snrm2 real(psb_spk_), external :: dnrm2
character(len=20), parameter :: name='mld_silut_factint' character(len=20), parameter :: name='mld_silut_factint'
if (psb_get_errstatus() /= 0) return if (psb_get_errstatus() /= 0) return
@ -518,23 +522,19 @@ contains
jmaxup = 0 jmaxup = 0
dmaxup = szero dmaxup = szero
nrmi = szero nrmi = szero
if (psb_toupper(a%fida) == 'CSR') then select type (aa=> a%a)
type is (psb_s_csr_sparse_mat)
! !
! Take a fast shortcut if the matrix is stored in CSR format ! Take a fast shortcut if the matrix is stored in CSR format
! !
do j = a%ia2(i), a%ia2(i+1) - 1 do j = aa%irp(i), aa%irp(i+1) - 1
k = a%ia1(j) k = aa%ja(j)
if ((jmin<=k).and.(k<=jmax)) then if ((jmin<=k).and.(k<=jmax)) then
row(k) = a%aspk(j) row(k) = aa%val(j)
call psb_insert_heap(k,heap,info) call psb_insert_heap(k,heap,info)
if (info /= psb_success_) then if (info /= psb_success_) exit
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_insert_heap')
goto 9999
end if
end if end if
if (k<jd) nlw = nlw + 1 if (k<jd) nlw = nlw + 1
if (k>jd) then if (k>jd) then
@ -545,9 +545,17 @@ contains
end if end if
end if end if
end do end do
nz = a%ia2(i+1) - a%ia2(i) if (info /= psb_success_) then
nrmi = snrm2(nz,a%aspk(a%ia2(i)),ione) info=psb_err_from_subroutine_
else call psb_errpush(info,name,a_err='psb_insert_heap')
goto 9999
end if
nz = aa%irp(i+1) - aa%irp(i)
nrmi = dnrm2(nz,aa%val(aa%irp(i)),ione)
class default
! !
! Otherwise use psb_sp_getblk, slower but able (in principle) of ! Otherwise use psb_sp_getblk, slower but able (in principle) of
@ -559,7 +567,7 @@ contains
if ((mod(i,nrb) == 1).or.(nrb == 1)) then if ((mod(i,nrb) == 1).or.(nrb == 1)) then
irb = min(m-i+1,nrb) irb = min(m-i+1,nrb)
call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1) call aa%csget(i,i+irb-1,trw,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_sp_getblk') call psb_errpush(info,name,a_err='psb_sp_getblk')
@ -569,18 +577,16 @@ contains
end if end if
kin = ktrw kin = ktrw
nz = trw%get_nzeros()
do do
if (ktrw > trw%infoa(psb_nnz_)) exit if (ktrw > nz) exit
if (trw%ia1(ktrw) > i) exit if (trw%ia(ktrw) > i) exit
k = trw%ia2(ktrw) k = trw%ja(ktrw)
if ((jmin<=k).and.(k<=jmax)) then if ((jmin<=k).and.(k<=jmax)) then
row(k) = trw%aspk(ktrw) row(k) = trw%val(ktrw)
call psb_insert_heap(k,heap,info) call psb_insert_heap(k,heap,info)
if (info /= psb_success_) then if (info /= psb_success_) exit
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_insert_heap')
goto 9999
end if
end if end if
if (k<jd) nlw = nlw + 1 if (k<jd) nlw = nlw + 1
if (k>jd) then if (k>jd) then
@ -593,8 +599,9 @@ contains
ktrw = ktrw + 1 ktrw = ktrw + 1
enddo enddo
nz = ktrw - kin nz = ktrw - kin
nrmi = snrm2(nz,trw%aspk(kin),ione) nrmi = dnrm2(nz,trw%val(kin),ione)
end if end select
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -644,17 +651,17 @@ contains
! d - real(psb_spk_), input. ! d - real(psb_spk_), input.
! The inverse of the diagonal entries of the part of the U factor ! The inverse of the diagonal entries of the part of the U factor
! above the current row (see ilut_copyout). ! above the current row (see ilut_copyout).
! uia1 - integer, dimension(:), input. ! uja - integer, dimension(:), input.
! The column indices of the nonzero entries of the part of the U ! The column indices of the nonzero entries of the part of the U
! factor above the current row, stored in uaspk row by row (see ! factor above the current row, stored in uval row by row (see
! ilut_copyout, called by mld_silut_factint), according to the CSR ! ilut_copyout, called by mld_silut_factint), according to the CSR
! storage format. ! storage format.
! uia2 - integer, dimension(:), input. ! uirp - integer, dimension(:), input.
! The indices identifying the first nonzero entry of each row of ! The indices identifying the first nonzero entry of each row of
! the U factor above the current row, stored in uaspk row by row ! the U factor above the current row, stored in uval row by row
! (see ilut_copyout, called by mld_silut_factint), according to ! (see ilut_copyout, called by mld_silut_factint), according to
! the CSR storage format. ! the CSR storage format.
! uaspk - real(psb_spk_), dimension(:), input. ! uval - real(psb_spk_), dimension(:), input.
! The entries of the U factor above the current row (except the ! The entries of the U factor above the current row (except the
! diagonal ones), stored according to the CSR format. ! diagonal ones), stored according to the CSR format.
! nidx - integer, output. ! nidx - integer, output.
@ -668,7 +675,7 @@ contains
! Note: this argument is intent(inout) and not only intent(out) ! Note: this argument is intent(inout) and not only intent(out)
! to retain its allocation, done by this routine. ! to retain its allocation, done by this routine.
! !
subroutine ilut_fact(thres,i,nrmi,row,heap,d,uia1,uia2,uaspk,nidx,idxs,info) subroutine ilut_fact(thres,i,nrmi,row,heap,d,uja,uirp,uval,nidx,idxs,info)
use psb_sparse_mod use psb_sparse_mod
@ -680,8 +687,8 @@ contains
integer, intent(inout) :: nidx,info integer, intent(inout) :: nidx,info
real(psb_spk_), intent(in) :: thres,nrmi real(psb_spk_), intent(in) :: thres,nrmi
integer, allocatable, intent(inout) :: idxs(:) integer, allocatable, intent(inout) :: idxs(:)
integer, intent(inout) :: uia1(:),uia2(:) integer, intent(inout) :: uja(:),uirp(:)
real(psb_spk_), intent(inout) :: row(:), uaspk(:),d(:) real(psb_spk_), intent(inout) :: row(:), uval(:),d(:)
! Local Variables ! Local Variables
integer :: k,j,jj,lastk,iret integer :: k,j,jj,lastk,iret
@ -725,8 +732,8 @@ contains
! Note: since U is scaled while copying it out (see ilut_copyout), ! Note: since U is scaled while copying it out (see ilut_copyout),
! we can use rwk in the update below. ! we can use rwk in the update below.
! !
do jj=uia2(k),uia2(k+1)-1 do jj=uirp(k),uirp(k+1)-1
j = uia1(jj) j = uja(jj)
if (j<=k) then if (j<=k) then
info = -i info = -i
return return
@ -735,7 +742,7 @@ contains
! Update row(j) and, if it is not to be discarded, insert ! Update row(j) and, if it is not to be discarded, insert
! its index into the heap for further processing. ! its index into the heap for further processing.
! !
row(j) = row(j) - rwk * uaspk(jj) row(j) = row(j) - rwk * uval(jj)
if (abs(row(j)) < thres*nrmi) then if (abs(row(j)) < thres*nrmi) then
! !
! Drop the entry. ! Drop the entry.
@ -770,8 +777,8 @@ contains
! Note: internal subroutine of mld_silut_fact ! Note: internal subroutine of mld_silut_fact
! !
! This routine copies a matrix row, computed by ilut_fact by applying an ! This routine copies a matrix row, computed by ilut_fact by applying an
! elimination step of the ILU(k,t) factorization, into the arrays laspk, ! elimination step of the ILU(k,t) factorization, into the arrays lval,
! uaspk, d, corresponding to the L factor, the U factor and the diagonal ! uval, d, corresponding to the L factor, the U factor and the diagonal
! of U, respectively. ! of U, respectively.
! !
! Note that ! Note that
@ -780,11 +787,11 @@ contains
! the 'lower part' of the row, and the nup+k ones in the 'upper part'; ! the 'lower part' of the row, and the nup+k ones in the 'upper part';
! - the entry in the upper part of the row which has maximum absolute value ! - the entry in the upper part of the row which has maximum absolute value
! in the original matrix is included in the above nup+k entries anyway; ! in the original matrix is included in the above nup+k entries anyway;
! - the part of the row stored into uaspk is scaled by the corresponding ! - the part of the row stored into uval is scaled by the corresponding
! diagonal entry, according to the LDU form of the incomplete factorization; ! diagonal entry, according to the LDU form of the incomplete factorization;
! - the inverse of the diagonal entries of U is actually stored into d; this ! - the inverse of the diagonal entries of U is actually stored into d; this
! is then managed in the solve stage associated to the ILU(k,t) factorization; ! is then managed in the solve stage associated to the ILU(k,t) factorization;
! - the row entries are stored in laspk and uaspk according to the CSR format; ! - the row entries are stored in lval and uval according to the CSR format;
! - the array row is re-initialized for future use in mld_ilut_fact(see also ! - the array row is re-initialized for future use in mld_ilut_fact(see also
! ilut_copyin and ilut_fact). ! ilut_copyin and ilut_fact).
! !
@ -824,37 +831,37 @@ contains
! examined during the elimination step carried out by the routine ! examined during the elimination step carried out by the routine
! ilut_fact. ! ilut_fact.
! l1 - integer, input/output. ! l1 - integer, input/output.
! Pointer to the last occupied entry of laspk. ! Pointer to the last occupied entry of lval.
! l2 - integer, input/output. ! l2 - integer, input/output.
! Pointer to the last occupied entry of uaspk. ! Pointer to the last occupied entry of uval.
! lia1 - integer, dimension(:), input/output. ! lja - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the L factor, ! The column indices of the nonzero entries of the L factor,
! copied in laspk row by row (see mld_silut_factint), according ! copied in lval row by row (see mld_silut_factint), according
! to the CSR storage format. ! to the CSR storage format.
! lia2 - integer, dimension(:), input/output. ! lirp - integer, dimension(:), input/output.
! The indices identifying the first nonzero entry of each row ! The indices identifying the first nonzero entry of each row
! of the L factor, copied in laspk row by row (see ! of the L factor, copied in lval row by row (see
! mld_silut_factint), according to the CSR storage format. ! mld_silut_factint), according to the CSR storage format.
! laspk - real(psb_spk_), dimension(:), input/output. ! lval - real(psb_spk_), dimension(:), input/output.
! The array where the entries of the row corresponding to the ! The array where the entries of the row corresponding to the
! L factor are copied. ! L factor are copied.
! d - real(psb_spk_), dimension(:), input/output. ! d - real(psb_spk_), dimension(:), input/output.
! The array where the inverse of the diagonal entry of the ! The array where the inverse of the diagonal entry of the
! row is copied (only d(i) is used by the routine). ! row is copied (only d(i) is used by the routine).
! uia1 - integer, dimension(:), input/output. ! uja - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the U factor ! The column indices of the nonzero entries of the U factor
! copied in uaspk row by row (see mld_silut_factint), according ! copied in uval row by row (see mld_silut_factint), according
! to the CSR storage format. ! to the CSR storage format.
! uia2 - integer, dimension(:), input/output. ! uirp - integer, dimension(:), input/output.
! The indices identifying the first nonzero entry of each row ! The indices identifying the first nonzero entry of each row
! of the U factor copied in uaspk row by row (see ! of the U factor copied in uval row by row (see
! mld_silu_fctint), according to the CSR storage format. ! mld_silu_fctint), according to the CSR storage format.
! uaspk - real(psb_spk_), dimension(:), input/output. ! uval - real(psb_spk_), dimension(:), input/output.
! The array where the entries of the row corresponding to the ! The array where the entries of the row corresponding to the
! U factor are copied. ! U factor are copied.
! !
subroutine ilut_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row, & subroutine ilut_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row, &
& nidx,idxs,l1,l2,lia1,lia2,laspk,d,uia1,uia2,uaspk,info) & nidx,idxs,l1,l2,lja,lirp,lval,d,uja,uirp,uval,info)
use psb_sparse_mod use psb_sparse_mod
@ -864,18 +871,18 @@ contains
integer, intent(in) :: fill_in,i,m,nidx,nlw,nup,jmaxup integer, intent(in) :: fill_in,i,m,nidx,nlw,nup,jmaxup
integer, intent(in) :: idxs(:) integer, intent(in) :: idxs(:)
integer, intent(inout) :: l1,l2, info integer, intent(inout) :: l1,l2, info
integer, allocatable, intent(inout) :: uia1(:),uia2(:), lia1(:),lia2(:) integer, allocatable, intent(inout) :: uja(:),uirp(:), lja(:),lirp(:)
real(psb_spk_), intent(in) :: thres,nrmi real(psb_spk_), intent(in) :: thres,nrmi
real(psb_spk_),allocatable, intent(inout) :: uaspk(:), laspk(:) real(psb_spk_),allocatable, intent(inout) :: uval(:), lval(:)
real(psb_spk_), intent(inout) :: row(:), d(:) real(psb_spk_), intent(inout) :: row(:), d(:)
! Local variables ! Local variables
real(psb_spk_),allocatable :: xw(:) real(psb_spk_),allocatable :: xw(:)
integer, allocatable :: xwid(:), indx(:) integer, allocatable :: xwid(:), indx(:)
real(psb_spk_) :: witem real(psb_spk_) :: witem
integer :: widx integer :: widx
integer :: k,isz,err_act,int_err(5),idxp, nz integer :: k,isz,err_act,int_err(5),idxp, nz
type(psb_real_idx_heap) :: heap type(psb_real_idx_heap) :: heap
character(len=20), parameter :: name='ilut_copyout' character(len=20), parameter :: name='ilut_copyout'
character(len=20) :: ch_err character(len=20) :: ch_err
logical :: fndmaxup logical :: fndmaxup
@ -965,21 +972,21 @@ contains
! !
do k=1,nz do k=1,nz
l1 = l1 + 1 l1 = l1 + 1
if (size(laspk) < l1) then if (size(lval) < l1) then
! !
! Figure out a good reallocation size! ! Figure out a good reallocation size!
! !
isz = (max((l1/i)*m,int(1.2*l1),l1+100)) isz = (max((l1/i)*m,int(1.2*l1),l1+100))
call psb_realloc(isz,laspk,info) call psb_realloc(isz,lval,info)
if (info == psb_success_) call psb_realloc(isz,lia1,info) if (info == psb_success_) call psb_realloc(isz,lja,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate') call psb_errpush(info,name,a_err='Allocate')
goto 9999 goto 9999
end if end if
end if end if
lia1(l1) = xwid(k) lja(l1) = xwid(k)
laspk(l1) = xw(indx(k)) lval(l1) = xw(indx(k))
end do end do
! !
@ -1111,21 +1118,21 @@ contains
! !
do k=1,nz do k=1,nz
l2 = l2 + 1 l2 = l2 + 1
if (size(uaspk) < l2) then if (size(uval) < l2) then
! !
! Figure out a good reallocation size! ! Figure out a good reallocation size!
! !
isz = max((l2/i)*m,int(1.2*l2),l2+100) isz = max((l2/i)*m,int(1.2*l2),l2+100)
call psb_realloc(isz,uaspk,info) call psb_realloc(isz,uval,info)
if (info == psb_success_) call psb_realloc(isz,uia1,info) if (info == psb_success_) call psb_realloc(isz,uja,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate') call psb_errpush(info,name,a_err='Allocate')
goto 9999 goto 9999
end if end if
end if end if
uia1(l2) = xwid(k) uja(l2) = xwid(k)
uaspk(l2) = d(i)*xw(indx(k)) uval(l2) = d(i)*xw(indx(k))
end do end do
! !
@ -1137,10 +1144,10 @@ contains
! !
! Store the pointers to the first non occupied entry of in ! Store the pointers to the first non occupied entry of in
! laspk and uaspk ! lval and uval
! !
lia2(i+1) = l1 + 1 lirp(i+1) = l1 + 1
uia2(i+1) = l2 + 1 uirp(i+1) = l2 + 1
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

Write Preview
Loading…
Cancel
Save