psblas3:
Reworked preconditioner stuff. Currently contains some debug statements. base/modules/psb_c_mat_mod.f03 base/modules/psb_d_base_mat_mod.f03 base/modules/psb_d_mat_mod.f03 base/modules/psb_error_mod.F90 base/serial/f03/psb_d_csr_impl.f03 base/serial/f03/psb_s_csr_impl.f03 base/tools/psb_cspasb.f90 base/tools/psb_dspasb.f90 prec/Makefile prec/psb_c_bjacprec.f03 prec/psb_c_diagprec.f03 prec/psb_c_nullprec.f03 prec/psb_cbjac_aply.f90 prec/psb_cbjac_bld.f90 prec/psb_cdiagsc_bld.f90 prec/psb_cgprec_aply.f90 prec/psb_cilu_fct.f90 prec/psb_cprc_aply.f90 prec/psb_cprecbld.f90 prec/psb_cprecinit.f90 prec/psb_cprecset.f90 prec/psb_d_bjacprec.f03 prec/psb_dbjac_aply.f90 prec/psb_dbjac_bld.f90 prec/psb_ddiagsc_bld.f90 prec/psb_dgprec_aply.f90 prec/psb_dprc_aply.f90 prec/psb_dprecbld.f90 prec/psb_dprecinit.f90 prec/psb_dprecset.f90 prec/psb_prec_type.f03 prec/psb_s_bjacprec.f03 prec/psb_s_diagprec.f03 prec/psb_s_nullprec.f03 prec/psb_sbjac_aply.f90 prec/psb_sbjac_bld.f90 prec/psb_sdiagsc_bld.f90 prec/psb_sgprec_aply.f90 prec/psb_silu_fct.f90 prec/psb_sprc_aply.f90 prec/psb_sprecbld.f90 prec/psb_sprecinit.f90 prec/psb_sprecset.f90 prec/psb_z_bjacprec.f03 prec/psb_z_diagprec.f03 prec/psb_z_nullprec.f03 prec/psb_zbjac_aply.f90 prec/psb_zbjac_bld.f90 prec/psb_zdiagsc_bld.f90 prec/psb_zgprec_aply.f90 prec/psb_zilu_fct.f90 prec/psb_zprc_aply.f90 prec/psb_zprecbld.f90 prec/psb_zprecinit.f90 prec/psb_zprecset.f90 test/fileread/runs/cfs.inp test/fileread/runs/dfs.inp test/fileread/runs/zfs.inp test/pargen/Makefile test/pargen/runs/ppde.inp util/psb_mat_dist_mod.f90psblas3-type-indexed
Salvatore Filippone
15 years ago
parent
f3fd67a2ee
commit
feeb610418
@ -0,0 +1,569 @@
|
|||||||
|
module psb_c_bjacprec
|
||||||
|
use psb_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
type, extends(psb_c_base_prec_type) :: psb_c_bjac_prec_type
|
||||||
|
integer, allocatable :: iprcparm(:)
|
||||||
|
type(psb_c_sparse_mat), allocatable :: av(:)
|
||||||
|
complex(psb_spk_), allocatable :: d(:)
|
||||||
|
contains
|
||||||
|
procedure, pass(prec) :: apply => c_bjac_apply
|
||||||
|
procedure, pass(prec) :: precbld => c_bjac_precbld
|
||||||
|
procedure, pass(prec) :: precinit => c_bjac_precinit
|
||||||
|
procedure, pass(prec) :: c_base_precseti => c_bjac_precseti
|
||||||
|
procedure, pass(prec) :: c_base_precsetr => c_bjac_precsetr
|
||||||
|
procedure, pass(prec) :: c_base_precsetc => c_bjac_precsetc
|
||||||
|
procedure, pass(prec) :: precfree => c_bjac_precfree
|
||||||
|
procedure, pass(prec) :: precdescr => c_bjac_precdescr
|
||||||
|
procedure, pass(prec) :: sizeof => c_bjac_sizeof
|
||||||
|
end type psb_c_bjac_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
character(len=15), parameter, private :: &
|
||||||
|
& fact_names(0:2)=(/'None ','ILU(n) ',&
|
||||||
|
& 'ILU(eps) '/)
|
||||||
|
|
||||||
|
contains
|
||||||
|
|
||||||
|
|
||||||
|
subroutine c_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work)
|
||||||
|
use psb_base_mod
|
||||||
|
type(psb_desc_type),intent(in) :: desc_data
|
||||||
|
class(psb_c_bjac_prec_type), intent(in) :: prec
|
||||||
|
complex(psb_spk_),intent(in) :: alpha,beta
|
||||||
|
complex(psb_spk_),intent(in) :: x(:)
|
||||||
|
complex(psb_spk_),intent(inout) :: y(:)
|
||||||
|
integer, intent(out) :: info
|
||||||
|
character(len=1), optional :: trans
|
||||||
|
complex(psb_spk_),intent(inout), optional, target :: work(:)
|
||||||
|
|
||||||
|
! Local variables
|
||||||
|
integer :: n_row,n_col
|
||||||
|
complex(psb_spk_), pointer :: ww(:), aux(:)
|
||||||
|
integer :: ictxt,np,me, err_act, int_err(5)
|
||||||
|
integer :: debug_level, debug_unit
|
||||||
|
character :: trans_
|
||||||
|
character(len=20) :: name='c_bjac_prec_apply'
|
||||||
|
character(len=20) :: ch_err
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
debug_unit = psb_get_debug_unit()
|
||||||
|
debug_level = psb_get_debug_level()
|
||||||
|
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
|
||||||
|
call psb_errpush(40,name)
|
||||||
|
goto 9999
|
||||||
|
end select
|
||||||
|
|
||||||
|
|
||||||
|
n_row = psb_cd_get_local_rows(desc_data)
|
||||||
|
n_col = psb_cd_get_local_cols(desc_data)
|
||||||
|
|
||||||
|
if (size(x) < n_row) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(y) < n_row) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (.not.allocated(prec%d)) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner: D")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(prec%d) < n_row) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner: D")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
|
||||||
|
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 /= 0) then
|
||||||
|
call psb_errpush(4010,name,a_err='Allocate')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
endif
|
||||||
|
else
|
||||||
|
allocate(ww(n_col),aux(4*n_col),stat=info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4010,name,a_err='Allocate')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
select case(prec%iprcparm(psb_f_type_))
|
||||||
|
case(psb_f_ilu_n_)
|
||||||
|
|
||||||
|
select case(trans_)
|
||||||
|
case('N')
|
||||||
|
call psb_spsm(cone,prec%av(psb_l_pr_),x,czero,ww,desc_data,info,&
|
||||||
|
& trans=trans_,scale='L',diag=prec%d,choice=psb_none_,work=aux)
|
||||||
|
if(info ==0) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,&
|
||||||
|
& trans=trans_,scale='U',choice=psb_none_, work=aux)
|
||||||
|
|
||||||
|
case('T')
|
||||||
|
call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,&
|
||||||
|
& trans=trans_,scale='L',diag=prec%d,choice=psb_none_, work=aux)
|
||||||
|
if(info ==0) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,&
|
||||||
|
& trans=trans_,scale='U',choice=psb_none_,work=aux)
|
||||||
|
|
||||||
|
case('C')
|
||||||
|
call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,&
|
||||||
|
& trans=trans_,scale='L',diag=conjg(prec%d),choice=psb_none_, work=aux)
|
||||||
|
if(info ==0) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,&
|
||||||
|
& trans=trans_,scale='U',choice=psb_none_,work=aux)
|
||||||
|
|
||||||
|
end select
|
||||||
|
if (info /=0) then
|
||||||
|
ch_err="psb_spsm"
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
|
||||||
|
case default
|
||||||
|
info = 4001
|
||||||
|
call psb_errpush(info,name,a_err='Invalid factorization')
|
||||||
|
goto 9999
|
||||||
|
end select
|
||||||
|
|
||||||
|
call psb_halo(y,desc_data,info,data=psb_comm_mov_)
|
||||||
|
|
||||||
|
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_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 c_bjac_apply
|
||||||
|
|
||||||
|
subroutine c_bjac_precinit(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_bjac_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_bjac_precinit'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
call psb_realloc(psb_ifpsz,prec%iprcparm,info)
|
||||||
|
if (info /= 0) then
|
||||||
|
info = 4000
|
||||||
|
call psb_Errpush(info,name)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
prec%iprcparm(:) = 0
|
||||||
|
prec%iprcparm(psb_p_type_) = psb_bjac_
|
||||||
|
prec%iprcparm(psb_f_type_) = psb_f_ilu_n_
|
||||||
|
prec%iprcparm(psb_ilu_fill_in_) = 0
|
||||||
|
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine c_bjac_precinit
|
||||||
|
|
||||||
|
|
||||||
|
subroutine c_bjac_precbld(a,desc_a,prec,info,upd)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
use psb_prec_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
type(psb_c_sparse_mat), intent(in), target :: a
|
||||||
|
type(psb_desc_type), intent(in), target :: desc_a
|
||||||
|
class(psb_c_bjac_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
character, intent(in), optional :: upd
|
||||||
|
|
||||||
|
! .. Local Scalars ..
|
||||||
|
integer :: i, m
|
||||||
|
integer :: int_err(5)
|
||||||
|
character :: trans, unitd
|
||||||
|
type(psb_c_csr_sparse_mat), allocatable :: lf, uf
|
||||||
|
integer nztota, err_act, n_row, nrow_a,n_col, nhalo
|
||||||
|
integer :: ictxt,np,me
|
||||||
|
character(len=20) :: name='c_bjac_precbld'
|
||||||
|
character(len=20) :: ch_err
|
||||||
|
|
||||||
|
|
||||||
|
if(psb_get_errstatus() /= 0) return
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
ictxt=psb_cd_get_context(desc_a)
|
||||||
|
call psb_info(ictxt, me, np)
|
||||||
|
|
||||||
|
m = a%get_nrows()
|
||||||
|
if (m < 0) then
|
||||||
|
info = 10
|
||||||
|
int_err(1) = 1
|
||||||
|
int_err(2) = m
|
||||||
|
call psb_errpush(info,name,i_err=int_err)
|
||||||
|
goto 9999
|
||||||
|
endif
|
||||||
|
trans = 'N'
|
||||||
|
unitd = 'U'
|
||||||
|
|
||||||
|
select case(prec%iprcparm(psb_f_type_))
|
||||||
|
|
||||||
|
case(psb_f_ilu_n_)
|
||||||
|
|
||||||
|
if (allocated(prec%av)) then
|
||||||
|
if (size(prec%av) < psb_bp_ilu_avsz) then
|
||||||
|
do i=1,size(prec%av)
|
||||||
|
call prec%av(i)%free()
|
||||||
|
enddo
|
||||||
|
deallocate(prec%av,stat=info)
|
||||||
|
endif
|
||||||
|
end if
|
||||||
|
if (.not.allocated(prec%av)) then
|
||||||
|
allocate(prec%av(psb_max_avsz),stat=info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4000,name)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
endif
|
||||||
|
|
||||||
|
nrow_a = psb_cd_get_local_rows(desc_a)
|
||||||
|
nztota = a%get_nzeros()
|
||||||
|
|
||||||
|
n_col = psb_cd_get_local_cols(desc_a)
|
||||||
|
nhalo = n_col-nrow_a
|
||||||
|
n_row = nrow_a
|
||||||
|
|
||||||
|
allocate(lf,uf,stat=info)
|
||||||
|
if (info == 0) call lf%allocate(n_row,n_row,nztota)
|
||||||
|
if (info == 0) call uf%allocate(n_row,n_row,nztota)
|
||||||
|
|
||||||
|
if(info/=0) then
|
||||||
|
info=4010
|
||||||
|
ch_err='psb_sp_all'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
if (allocated(prec%d)) then
|
||||||
|
if (size(prec%d) < n_row) then
|
||||||
|
deallocate(prec%d)
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
if (.not.allocated(prec%d)) then
|
||||||
|
allocate(prec%d(n_row),stat=info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4010,name,a_err='Allocate')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
endif
|
||||||
|
! This is where we have no renumbering, thus no need
|
||||||
|
call psb_ilu_fct(a,lf,uf,prec%d,info)
|
||||||
|
|
||||||
|
if(info==0) then
|
||||||
|
call prec%av(psb_l_pr_)%mv_from(lf)
|
||||||
|
call prec%av(psb_u_pr_)%mv_from(uf)
|
||||||
|
call prec%av(psb_l_pr_)%set_asb()
|
||||||
|
call prec%av(psb_u_pr_)%set_asb()
|
||||||
|
call prec%av(psb_l_pr_)%trim()
|
||||||
|
call prec%av(psb_u_pr_)%trim()
|
||||||
|
else
|
||||||
|
info=4010
|
||||||
|
ch_err='psb_ilu_fct'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
!!$ call prec%av(psb_l_pr_)%print(30+me)
|
||||||
|
!!$ call prec%av(psb_u_pr_)%print(40+me)
|
||||||
|
!!$ do i=1,n_row
|
||||||
|
!!$ write(50+me,*) i,prec%d(i)
|
||||||
|
!!$ end do
|
||||||
|
|
||||||
|
case(psb_f_none_)
|
||||||
|
info=4010
|
||||||
|
ch_err='Inconsistent prec psb_f_none_'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
goto 9999
|
||||||
|
|
||||||
|
case default
|
||||||
|
info=4010
|
||||||
|
ch_err='Unknown psb_f_type_'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
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 c_bjac_precbld
|
||||||
|
|
||||||
|
subroutine c_bjac_precseti(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_bjac_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
integer, intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_bjac_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
if (.not.allocated(prec%iprcparm)) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
select case(what)
|
||||||
|
case (psb_f_type_)
|
||||||
|
if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then
|
||||||
|
write(0,*) 'WHAT is invalid for current preconditioner ',prec%iprcparm(psb_p_type_),&
|
||||||
|
& 'ignoring user specification'
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
prec%iprcparm(psb_f_type_) = val
|
||||||
|
|
||||||
|
case (psb_ilu_fill_in_)
|
||||||
|
if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.(prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then
|
||||||
|
write(0,*) 'WHAT is invalid for current preconditioner ',prec%iprcparm(psb_p_type_),&
|
||||||
|
& 'ignoring user specification'
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
prec%iprcparm(psb_ilu_fill_in_) = val
|
||||||
|
|
||||||
|
case default
|
||||||
|
write(0,*) 'WHAT is invalid, ignoring user specification'
|
||||||
|
|
||||||
|
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 c_bjac_precseti
|
||||||
|
|
||||||
|
subroutine c_bjac_precsetr(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_bjac_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
real(psb_spk_), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_bjac_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine c_bjac_precsetr
|
||||||
|
|
||||||
|
subroutine c_bjac_precsetc(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_bjac_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
character(len=*), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_bjac_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine c_bjac_precsetc
|
||||||
|
|
||||||
|
subroutine c_bjac_precfree(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_bjac_prec_type), intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
|
||||||
|
Integer :: err_act, i
|
||||||
|
character(len=20) :: name='c_bjac_precfree'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
if (allocated(prec%av)) then
|
||||||
|
do i=1,size(prec%av)
|
||||||
|
call prec%av(i)%free()
|
||||||
|
enddo
|
||||||
|
deallocate(prec%av,stat=info)
|
||||||
|
end if
|
||||||
|
if (allocated(prec%d)) then
|
||||||
|
deallocate(prec%d,stat=info)
|
||||||
|
end if
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
|
||||||
|
end subroutine c_bjac_precfree
|
||||||
|
|
||||||
|
|
||||||
|
subroutine c_bjac_precdescr(prec,iout)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_bjac_prec_type), intent(in) :: prec
|
||||||
|
integer, intent(in), optional :: iout
|
||||||
|
|
||||||
|
Integer :: err_act, nrow, info
|
||||||
|
character(len=20) :: name='c_bjac_precdescr'
|
||||||
|
integer :: iout_
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
if (present(iout)) then
|
||||||
|
iout_ = iout
|
||||||
|
else
|
||||||
|
iout_ = 6
|
||||||
|
end if
|
||||||
|
|
||||||
|
if (.not.allocated(prec%iprcparm)) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
write(iout_,*) 'Block Jacobi with: ',&
|
||||||
|
& fact_names(prec%iprcparm(psb_f_type_))
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
|
||||||
|
end subroutine c_bjac_precdescr
|
||||||
|
|
||||||
|
function c_bjac_sizeof(prec) result(val)
|
||||||
|
use psb_base_mod
|
||||||
|
class(psb_c_bjac_prec_type), intent(in) :: prec
|
||||||
|
integer(psb_long_int_k_) :: val
|
||||||
|
|
||||||
|
val = 0
|
||||||
|
if (allocated(prec%d)) then
|
||||||
|
val = val + 2*psb_sizeof_sp * size(prec%d)
|
||||||
|
endif
|
||||||
|
if (allocated(prec%av)) then
|
||||||
|
val = val + psb_sizeof(prec%av(psb_l_pr_))
|
||||||
|
val = val + psb_sizeof(prec%av(psb_u_pr_))
|
||||||
|
endif
|
||||||
|
return
|
||||||
|
end function c_bjac_sizeof
|
||||||
|
|
||||||
|
end module psb_c_bjacprec
|
||||||
@ -0,0 +1,375 @@
|
|||||||
|
module psb_c_diagprec
|
||||||
|
use psb_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
type, extends(psb_c_base_prec_type) :: psb_c_diag_prec_type
|
||||||
|
complex(psb_spk_), allocatable :: d(:)
|
||||||
|
contains
|
||||||
|
procedure, pass(prec) :: apply => c_diag_apply
|
||||||
|
procedure, pass(prec) :: precbld => c_diag_precbld
|
||||||
|
procedure, pass(prec) :: precinit => c_diag_precinit
|
||||||
|
procedure, pass(prec) :: c_base_precseti => c_diag_precseti
|
||||||
|
procedure, pass(prec) :: c_base_precsetr => c_diag_precsetr
|
||||||
|
procedure, pass(prec) :: c_base_precsetc => c_diag_precsetc
|
||||||
|
procedure, pass(prec) :: precfree => c_diag_precfree
|
||||||
|
procedure, pass(prec) :: precdescr => c_diag_precdescr
|
||||||
|
procedure, pass(prec) :: sizeof => c_diag_sizeof
|
||||||
|
end type psb_c_diag_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
contains
|
||||||
|
|
||||||
|
|
||||||
|
subroutine c_diag_apply(alpha,prec,x,beta,y,desc_data,info,trans,work)
|
||||||
|
use psb_base_mod
|
||||||
|
type(psb_desc_type),intent(in) :: desc_data
|
||||||
|
class(psb_c_diag_prec_type), intent(in) :: prec
|
||||||
|
complex(psb_spk_),intent(in) :: x(:)
|
||||||
|
complex(psb_spk_),intent(in) :: alpha, beta
|
||||||
|
complex(psb_spk_),intent(inout) :: y(:)
|
||||||
|
integer, intent(out) :: info
|
||||||
|
character(len=1), optional :: trans
|
||||||
|
complex(psb_spk_),intent(inout), optional, target :: work(:)
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character :: trans_
|
||||||
|
character(len=20) :: name='c_diag_prec_apply'
|
||||||
|
complex(psb_spk_), pointer :: ww(:)
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
!
|
||||||
|
! This is the base version and we should throw an error.
|
||||||
|
! Or should it be the DIAG preonditioner???
|
||||||
|
!
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
|
||||||
|
nrow = psb_cd_get_local_rows(desc_data)
|
||||||
|
if (size(x) < nrow) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(y) < nrow) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (.not.allocated(prec%d)) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner: D")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(prec%d) < nrow) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner: D")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (present(trans)) then
|
||||||
|
trans_ = psb_toupper(trans)
|
||||||
|
else
|
||||||
|
trans_='N'
|
||||||
|
end if
|
||||||
|
|
||||||
|
select case(trans_)
|
||||||
|
case('N')
|
||||||
|
case('T','C')
|
||||||
|
case default
|
||||||
|
info=40
|
||||||
|
call psb_errpush(info,name,&
|
||||||
|
& i_err=(/6,0,0,0,0/),a_err=trans_)
|
||||||
|
goto 9999
|
||||||
|
end select
|
||||||
|
|
||||||
|
if (size(work) >= size(x)) then
|
||||||
|
ww => work
|
||||||
|
else
|
||||||
|
allocate(ww(size(x)),stat=info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4025,name,&
|
||||||
|
& i_err=(/size(x),0,0,0,0/),a_err='complex(psb_spk_)')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
end if
|
||||||
|
|
||||||
|
|
||||||
|
if (trans_=='C') then
|
||||||
|
ww(1:nrow) = x(1:nrow)*conjg(prec%d(1:nrow))
|
||||||
|
else
|
||||||
|
ww(1:nrow) = x(1:nrow)*prec%d(1:nrow)
|
||||||
|
endif
|
||||||
|
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
|
||||||
|
|
||||||
|
if (size(work) < size(x)) then
|
||||||
|
deallocate(ww,stat=info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4010,name,a_err='Deallocate')
|
||||||
|
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 c_diag_apply
|
||||||
|
|
||||||
|
subroutine c_diag_precinit(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_diag_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_diag_precinit'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine c_diag_precinit
|
||||||
|
|
||||||
|
|
||||||
|
subroutine c_diag_precbld(a,desc_a,prec,info,upd)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
type(psb_c_sparse_mat), intent(in), target :: a
|
||||||
|
type(psb_desc_type), intent(in), target :: desc_a
|
||||||
|
class(psb_c_diag_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
character, intent(in), optional :: upd
|
||||||
|
Integer :: err_act, nrow,i
|
||||||
|
character(len=20) :: name='c_diag_precbld'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
nrow = psb_cd_get_local_cols(desc_a)
|
||||||
|
if (allocated(prec%d)) then
|
||||||
|
if (size(prec%d) < nrow) then
|
||||||
|
deallocate(prec%d,stat=info)
|
||||||
|
end if
|
||||||
|
end if
|
||||||
|
if ((info == 0).and.(.not.allocated(prec%d))) then
|
||||||
|
allocate(prec%d(nrow), stat=info)
|
||||||
|
end if
|
||||||
|
if (info /= 0) then
|
||||||
|
info = 4000
|
||||||
|
call psb_errpush(info,name)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
call a%get_diag(prec%d,info)
|
||||||
|
if (info /= 0) then
|
||||||
|
info = 4010
|
||||||
|
call psb_errpush(info,name, a_err='get_diag')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
do i=1,nrow
|
||||||
|
if (prec%d(i) == dzero) then
|
||||||
|
prec%d(i) = done
|
||||||
|
else
|
||||||
|
prec%d(i) = done/prec%d(i)
|
||||||
|
endif
|
||||||
|
end do
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine c_diag_precbld
|
||||||
|
|
||||||
|
subroutine c_diag_precseti(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_diag_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
integer, intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_diag_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine c_diag_precseti
|
||||||
|
|
||||||
|
subroutine c_diag_precsetr(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_diag_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
real(psb_spk_), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_diag_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine c_diag_precsetr
|
||||||
|
|
||||||
|
subroutine c_diag_precsetc(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_diag_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
character(len=*), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_diag_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine c_diag_precsetc
|
||||||
|
|
||||||
|
subroutine c_diag_precfree(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_diag_prec_type), intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_diag_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
|
||||||
|
end subroutine c_diag_precfree
|
||||||
|
|
||||||
|
|
||||||
|
subroutine c_diag_precdescr(prec,iout)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_diag_prec_type), intent(in) :: prec
|
||||||
|
integer, intent(in), optional :: iout
|
||||||
|
|
||||||
|
Integer :: err_act, nrow, info
|
||||||
|
character(len=20) :: name='c_diag_precdescr'
|
||||||
|
|
||||||
|
integer :: iout_
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
if (present(iout)) then
|
||||||
|
iout_ = iout
|
||||||
|
else
|
||||||
|
iout_ = 6
|
||||||
|
end if
|
||||||
|
|
||||||
|
write(iout_,*) 'Diagonal scaling'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
|
||||||
|
end subroutine c_diag_precdescr
|
||||||
|
|
||||||
|
function c_diag_sizeof(prec) result(val)
|
||||||
|
use psb_base_mod
|
||||||
|
class(psb_c_diag_prec_type), intent(in) :: prec
|
||||||
|
integer(psb_long_int_k_) :: val
|
||||||
|
|
||||||
|
val = 0
|
||||||
|
val = val + 2*psb_sizeof_sp * size(prec%d)
|
||||||
|
return
|
||||||
|
end function c_diag_sizeof
|
||||||
|
|
||||||
|
end module psb_c_diagprec
|
||||||
@ -0,0 +1,293 @@
|
|||||||
|
module psb_c_nullprec
|
||||||
|
use psb_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
type, extends(psb_c_base_prec_type) :: psb_c_null_prec_type
|
||||||
|
contains
|
||||||
|
procedure, pass(prec) :: apply => c_null_apply
|
||||||
|
procedure, pass(prec) :: precbld => c_null_precbld
|
||||||
|
procedure, pass(prec) :: precinit => c_null_precinit
|
||||||
|
procedure, pass(prec) :: c_base_precseti => c_null_precseti
|
||||||
|
procedure, pass(prec) :: c_base_precsetr => c_null_precsetr
|
||||||
|
procedure, pass(prec) :: c_base_precsetc => c_null_precsetc
|
||||||
|
procedure, pass(prec) :: precfree => c_null_precfree
|
||||||
|
procedure, pass(prec) :: precdescr => c_null_precdescr
|
||||||
|
procedure, pass(prec) :: sizeof => c_null_sizeof
|
||||||
|
end type psb_c_null_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
contains
|
||||||
|
|
||||||
|
|
||||||
|
subroutine c_null_apply(alpha,prec,x,beta,y,desc_data,info,trans,work)
|
||||||
|
use psb_base_mod
|
||||||
|
type(psb_desc_type),intent(in) :: desc_data
|
||||||
|
class(psb_c_null_prec_type), intent(in) :: prec
|
||||||
|
complex(psb_spk_),intent(in) :: x(:)
|
||||||
|
complex(psb_spk_),intent(in) :: alpha, beta
|
||||||
|
complex(psb_spk_),intent(inout) :: y(:)
|
||||||
|
integer, intent(out) :: info
|
||||||
|
character(len=1), optional :: trans
|
||||||
|
complex(psb_spk_),intent(inout), optional, target :: work(:)
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_null_prec_apply'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
!
|
||||||
|
! This is the base version and we should throw an error.
|
||||||
|
! Or should it be the NULL preonditioner???
|
||||||
|
!
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
nrow = psb_cd_get_local_rows(desc_data)
|
||||||
|
if (size(x) < nrow) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(y) < nrow) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||||
|
if (info /= 0 ) then
|
||||||
|
info = 4010
|
||||||
|
call psb_errpush(infoi,name,a_err="psb_geaxpby")
|
||||||
|
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 c_null_apply
|
||||||
|
|
||||||
|
|
||||||
|
subroutine c_null_precinit(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_null_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_null_precinit'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine c_null_precinit
|
||||||
|
|
||||||
|
subroutine c_null_precbld(a,desc_a,prec,info,upd)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
type(psb_c_sparse_mat), intent(in), target :: a
|
||||||
|
type(psb_desc_type), intent(in), target :: desc_a
|
||||||
|
class(psb_c_null_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
character, intent(in), optional :: upd
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_null_precbld'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine c_null_precbld
|
||||||
|
|
||||||
|
subroutine c_null_precseti(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_null_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
integer, intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_null_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine c_null_precseti
|
||||||
|
|
||||||
|
subroutine c_null_precsetr(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_null_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
real(psb_spk_), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_null_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine c_null_precsetr
|
||||||
|
|
||||||
|
subroutine c_null_precsetc(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_null_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
character(len=*), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_null_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine c_null_precsetc
|
||||||
|
|
||||||
|
subroutine c_null_precfree(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_null_prec_type), intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_null_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
|
||||||
|
end subroutine c_null_precfree
|
||||||
|
|
||||||
|
|
||||||
|
subroutine c_null_precdescr(prec,iout)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_c_null_prec_type), intent(in) :: prec
|
||||||
|
integer, intent(in), optional :: iout
|
||||||
|
|
||||||
|
Integer :: err_act, nrow, info
|
||||||
|
character(len=20) :: name='c_null_precset'
|
||||||
|
integer :: iout_
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
if (present(iout)) then
|
||||||
|
iout_ = iout
|
||||||
|
else
|
||||||
|
iout_ = 6
|
||||||
|
end if
|
||||||
|
|
||||||
|
write(iout_,*) 'No preconditioning'
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
|
||||||
|
end subroutine c_null_precdescr
|
||||||
|
|
||||||
|
function c_null_sizeof(prec) result(val)
|
||||||
|
use psb_base_mod
|
||||||
|
class(psb_c_null_prec_type), intent(in) :: prec
|
||||||
|
integer(psb_long_int_k_) :: val
|
||||||
|
|
||||||
|
val = 0
|
||||||
|
|
||||||
|
return
|
||||||
|
end function c_null_sizeof
|
||||||
|
|
||||||
|
end module psb_c_nullprec
|
||||||
@ -1,166 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS version 2.2
|
|
||||||
!!$ (C) Copyright 2006/2007/2008
|
|
||||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ 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 PSBLAS 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 PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
subroutine psb_cbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
|
|
||||||
!
|
|
||||||
! Compute Y <- beta*Y + alpha*K^-1 X
|
|
||||||
! where K is a a Block Jacobi preconditioner stored in prec
|
|
||||||
! Note that desc_data may or may not be the same as prec%desc_data,
|
|
||||||
! but since both are INTENT(IN) this should be legal.
|
|
||||||
!
|
|
||||||
|
|
||||||
use psb_base_mod
|
|
||||||
use psb_prec_mod, psb_protect_name => psb_cbjac_aply
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
type(psb_desc_type), intent(in) :: desc_data
|
|
||||||
type(psb_cprec_type), intent(in) :: prec
|
|
||||||
complex(psb_spk_),intent(in) :: x(:)
|
|
||||||
complex(psb_spk_),intent(inout) :: y(:)
|
|
||||||
complex(psb_spk_),intent(in) :: alpha,beta
|
|
||||||
character(len=1) :: trans
|
|
||||||
complex(psb_spk_),target :: work(:)
|
|
||||||
integer, intent(out) :: info
|
|
||||||
|
|
||||||
! Local variables
|
|
||||||
integer :: n_row,n_col
|
|
||||||
complex(psb_spk_), pointer :: ww(:), aux(:)
|
|
||||||
integer :: ictxt,np,me, err_act, int_err(5)
|
|
||||||
integer :: debug_level, debug_unit
|
|
||||||
character :: trans_
|
|
||||||
character(len=20) :: name, ch_err
|
|
||||||
|
|
||||||
name='psb_bjac_aply'
|
|
||||||
info = 0
|
|
||||||
call psb_erractionsave(err_act)
|
|
||||||
debug_unit = psb_get_debug_unit()
|
|
||||||
debug_level = psb_get_debug_level()
|
|
||||||
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
|
|
||||||
call psb_errpush(40,name)
|
|
||||||
goto 9999
|
|
||||||
end select
|
|
||||||
|
|
||||||
|
|
||||||
n_row=desc_data%matrix_data(psb_n_row_)
|
|
||||||
n_col=desc_data%matrix_data(psb_n_col_)
|
|
||||||
|
|
||||||
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 /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Allocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
endif
|
|
||||||
else
|
|
||||||
allocate(ww(n_col),aux(4*n_col),stat=info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Allocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
endif
|
|
||||||
|
|
||||||
|
|
||||||
select case(prec%iprcparm(psb_f_type_))
|
|
||||||
case(psb_f_ilu_n_)
|
|
||||||
|
|
||||||
select case(trans_)
|
|
||||||
case('N')
|
|
||||||
|
|
||||||
call psb_spsm(cone,prec%av(psb_l_pr_),x,czero,ww,desc_data,info,&
|
|
||||||
& trans=trans_,scale='L',diag=prec%d,choice=psb_none_,work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,&
|
|
||||||
& trans=trans_,scale='U',choice=psb_none_, work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
|
|
||||||
case('T')
|
|
||||||
call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,&
|
|
||||||
& trans=trans_,scale='L',diag=prec%d,choice=psb_none_, work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,&
|
|
||||||
& trans=trans_,scale='U',choice=psb_none_,work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
|
|
||||||
case('C')
|
|
||||||
call psb_spsm(cone,prec%av(psb_u_pr_),x,czero,ww,desc_data,info,&
|
|
||||||
& trans=trans_,scale='L',diag=conjg(prec%d),choice=psb_none_, work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,&
|
|
||||||
& trans=trans_,scale='U',choice=psb_none_,work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
|
|
||||||
end select
|
|
||||||
|
|
||||||
|
|
||||||
case default
|
|
||||||
info = 4001
|
|
||||||
call psb_errpush(info,name,a_err='Invalid factorization')
|
|
||||||
goto 9999
|
|
||||||
end select
|
|
||||||
|
|
||||||
call psb_halo(y,desc_data,info,data=psb_comm_mov_)
|
|
||||||
|
|
||||||
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_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 psb_cbjac_aply
|
|
||||||
@ -1,181 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS version 2.2
|
|
||||||
!!$ (C) Copyright 2006/2007/2008
|
|
||||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ 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 PSBLAS 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 PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
subroutine psb_cbjac_bld(a,desc_a,p,upd,info)
|
|
||||||
use psb_base_mod
|
|
||||||
use psb_prec_mod, psb_protect_name => psb_cbjac_bld
|
|
||||||
implicit none
|
|
||||||
!
|
|
||||||
! .. Scalar Arguments ..
|
|
||||||
integer, intent(out) :: info
|
|
||||||
! .. array Arguments ..
|
|
||||||
type(psb_c_sparse_mat), intent(in), target :: a
|
|
||||||
type(psb_cprec_type), intent(inout) :: p
|
|
||||||
type(psb_desc_type), intent(in) :: desc_a
|
|
||||||
character, intent(in) :: upd
|
|
||||||
|
|
||||||
! .. Local Scalars ..
|
|
||||||
integer :: i, m
|
|
||||||
integer :: int_err(5)
|
|
||||||
character :: trans, unitd
|
|
||||||
type(psb_c_csr_sparse_mat), allocatable :: lf, uf
|
|
||||||
real(psb_dpk_) :: t1,t2,t3,t4,t5,t6, t7, t8
|
|
||||||
integer nztota, err_act, n_row, nrow_a,n_col, nhalo
|
|
||||||
integer :: ictxt,np,me
|
|
||||||
character(len=20) :: name, ch_err
|
|
||||||
|
|
||||||
|
|
||||||
if(psb_get_errstatus() /= 0) return
|
|
||||||
info=0
|
|
||||||
name='psb_cbjac_bld'
|
|
||||||
call psb_erractionsave(err_act)
|
|
||||||
|
|
||||||
ictxt=psb_cd_get_context(desc_a)
|
|
||||||
call psb_info(ictxt, me, np)
|
|
||||||
|
|
||||||
m = a%get_nrows()
|
|
||||||
if (m < 0) then
|
|
||||||
info = 10
|
|
||||||
int_err(1) = 1
|
|
||||||
int_err(2) = m
|
|
||||||
call psb_errpush(info,name,i_err=int_err)
|
|
||||||
goto 9999
|
|
||||||
endif
|
|
||||||
trans = 'N'
|
|
||||||
unitd = 'U'
|
|
||||||
|
|
||||||
call psb_cdcpy(desc_a,p%desc_data,info)
|
|
||||||
if(info /= 0) then
|
|
||||||
info=4010
|
|
||||||
ch_err='psb_cdcpy'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
|
|
||||||
select case(p%iprcparm(psb_f_type_))
|
|
||||||
|
|
||||||
case(psb_f_ilu_n_)
|
|
||||||
|
|
||||||
if (allocated(p%av)) then
|
|
||||||
if (size(p%av) < psb_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(psb_max_avsz),stat=info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4000,name)
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
endif
|
|
||||||
|
|
||||||
nrow_a = psb_cd_get_local_rows(desc_a)
|
|
||||||
nztota = a%get_nzeros()
|
|
||||||
|
|
||||||
n_col = psb_cd_get_local_cols(desc_a)
|
|
||||||
nhalo = n_col-nrow_a
|
|
||||||
n_row = p%desc_data%matrix_data(psb_n_row_)
|
|
||||||
|
|
||||||
allocate(lf,uf,stat=info)
|
|
||||||
if (info == 0) call lf%allocate(n_row,n_row,nztota)
|
|
||||||
if (info == 0) call uf%allocate(n_row,n_row,nztota)
|
|
||||||
|
|
||||||
if(info/=0) then
|
|
||||||
info=4010
|
|
||||||
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 /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Allocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
endif
|
|
||||||
t3 = psb_wtime()
|
|
||||||
! This is where we have no renumbering, thus no need
|
|
||||||
call psb_ilu_fct(a,lf,uf,p%d,info)
|
|
||||||
|
|
||||||
if(info==0) then
|
|
||||||
call p%av(psb_l_pr_)%mv_from(lf)
|
|
||||||
call p%av(psb_u_pr_)%mv_from(uf)
|
|
||||||
call p%av(psb_l_pr_)%set_asb()
|
|
||||||
call p%av(psb_u_pr_)%set_asb()
|
|
||||||
call p%av(psb_l_pr_)%trim()
|
|
||||||
call p%av(psb_u_pr_)%trim()
|
|
||||||
else
|
|
||||||
info=4010
|
|
||||||
ch_err='psb_ilu_fct'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
case(psb_f_none_)
|
|
||||||
info=4010
|
|
||||||
ch_err='Inconsistent prec psb_f_none_'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
goto 9999
|
|
||||||
|
|
||||||
case default
|
|
||||||
info=4010
|
|
||||||
ch_err='Unknown psb_f_type_'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
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 psb_cbjac_bld
|
|
||||||
|
|
||||||
|
|
||||||
@ -1,120 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS version 2.2
|
|
||||||
!!$ (C) Copyright 2006/2007/2008
|
|
||||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ 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 PSBLAS 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 PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
subroutine psb_cdiagsc_bld(a,desc_a,p,upd,info)
|
|
||||||
|
|
||||||
use psb_base_mod
|
|
||||||
use psb_prec_mod, psb_protect_name => psb_cdiagsc_bld
|
|
||||||
Implicit None
|
|
||||||
|
|
||||||
type(psb_c_sparse_mat), intent(in), target :: a
|
|
||||||
type(psb_desc_type), intent(in) :: desc_a
|
|
||||||
type(psb_cprec_type),intent(inout) :: p
|
|
||||||
character, intent(in) :: upd
|
|
||||||
integer, intent(out) :: info
|
|
||||||
|
|
||||||
|
|
||||||
! Local scalars
|
|
||||||
Integer :: err, n_row, n_col,I,ictxt,&
|
|
||||||
& me,np,mglob,err_act
|
|
||||||
integer :: int_err(5)
|
|
||||||
|
|
||||||
integer,parameter :: iroot=psb_root_,iout=60,ilout=40
|
|
||||||
character(len=20) :: name, ch_err
|
|
||||||
|
|
||||||
if(psb_get_errstatus() /= 0) return
|
|
||||||
info=0
|
|
||||||
err=0
|
|
||||||
call psb_erractionsave(err_act)
|
|
||||||
name = 'psb_diagsc_bld'
|
|
||||||
|
|
||||||
info = 0
|
|
||||||
int_err(1) = 0
|
|
||||||
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)
|
|
||||||
|
|
||||||
! diagonal scaling
|
|
||||||
|
|
||||||
call psb_realloc(n_col,p%d,info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='psb_realloc')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
!
|
|
||||||
! Retrieve the diagonal entries of the matrix A
|
|
||||||
!
|
|
||||||
call a%get_diag(p%d,info)
|
|
||||||
if(info /= 0) then
|
|
||||||
info=4010
|
|
||||||
ch_err='psb_sp_getdiag'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
!
|
|
||||||
! Copy into p%desc_data the descriptor associated to A
|
|
||||||
!
|
|
||||||
call psb_cdcpy(desc_a,p%desc_Data,info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='psb_cdcpy')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
!
|
|
||||||
! The i-th diagonal entry of the preconditioner is set to one if the
|
|
||||||
! corresponding entry a_ii of the sparse matrix A is zero; otherwise
|
|
||||||
! it is set to one/a_ii
|
|
||||||
!
|
|
||||||
do i=1,n_row
|
|
||||||
if (p%d(i) == czero) then
|
|
||||||
p%d(i) = cone
|
|
||||||
else
|
|
||||||
p%d(i) = cone/p%d(i)
|
|
||||||
endif
|
|
||||||
end do
|
|
||||||
|
|
||||||
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 psb_cdiagsc_bld
|
|
||||||
|
|
||||||
@ -1,140 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS version 2.2
|
|
||||||
!!$ (C) Copyright 2006/2007/2008
|
|
||||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ 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 PSBLAS 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 PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
subroutine psb_cgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
|
|
||||||
!
|
|
||||||
! Compute Y <- beta*Y + alpha*K^-1 X
|
|
||||||
! where K is a a basic preconditioner stored in prec
|
|
||||||
!
|
|
||||||
|
|
||||||
use psb_base_mod
|
|
||||||
use psb_prec_mod, psb_protect_name => psb_cgprec_aply
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
type(psb_desc_type),intent(in) :: desc_data
|
|
||||||
type(psb_cprec_type), intent(in) :: prec
|
|
||||||
complex(psb_spk_),intent(in) :: x(:)
|
|
||||||
complex(psb_spk_),intent(inout) :: y(:)
|
|
||||||
complex(psb_spk_),intent(in) :: alpha,beta
|
|
||||||
character(len=1) :: trans
|
|
||||||
complex(psb_spk_),target :: work(:)
|
|
||||||
integer, intent(out) :: info
|
|
||||||
|
|
||||||
! Local variables
|
|
||||||
integer :: n_row,int_err(5)
|
|
||||||
complex(psb_spk_), pointer :: ww(:)
|
|
||||||
character :: trans_
|
|
||||||
integer :: ictxt,np,me, err_act
|
|
||||||
character(len=20) :: name, ch_err
|
|
||||||
|
|
||||||
|
|
||||||
name='psb_cgprec_aply'
|
|
||||||
info = 0
|
|
||||||
call psb_erractionsave(err_act)
|
|
||||||
|
|
||||||
ictxt=desc_data%matrix_data(psb_ctxt_)
|
|
||||||
call psb_info(ictxt, me, np)
|
|
||||||
|
|
||||||
trans_ = psb_toupper(trans)
|
|
||||||
|
|
||||||
select case(trans_)
|
|
||||||
case('N')
|
|
||||||
case('T','C')
|
|
||||||
case default
|
|
||||||
info=40
|
|
||||||
int_err(1)=6
|
|
||||||
ch_err(2:2)=trans
|
|
||||||
goto 9999
|
|
||||||
end select
|
|
||||||
|
|
||||||
select case(prec%iprcparm(psb_p_type_))
|
|
||||||
|
|
||||||
case(psb_noprec_)
|
|
||||||
|
|
||||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
|
||||||
|
|
||||||
case(psb_diag_)
|
|
||||||
|
|
||||||
if (size(work) >= size(x)) then
|
|
||||||
ww => work
|
|
||||||
else
|
|
||||||
allocate(ww(size(x)),stat=info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Allocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
end if
|
|
||||||
|
|
||||||
n_row=desc_data%matrix_data(psb_n_row_)
|
|
||||||
if (trans_=='C') then
|
|
||||||
ww(1:n_row) = x(1:n_row)*conjg(prec%d(1:n_row))
|
|
||||||
else
|
|
||||||
ww(1:n_row) = x(1:n_row)*prec%d(1:n_row)
|
|
||||||
endif
|
|
||||||
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
|
|
||||||
|
|
||||||
if (size(work) < size(x)) then
|
|
||||||
deallocate(ww,stat=info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Deallocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
end if
|
|
||||||
|
|
||||||
case(psb_bjac_)
|
|
||||||
|
|
||||||
call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info)
|
|
||||||
if(info /= 0) then
|
|
||||||
info=4010
|
|
||||||
ch_err='psb_bjac_aply'
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
case default
|
|
||||||
info = 4001
|
|
||||||
call psb_errpush(info,name,a_err='Invalid prectype')
|
|
||||||
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 psb_cgprec_aply
|
|
||||||
|
|
||||||
@ -1,158 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS version 2.2
|
|
||||||
!!$ (C) Copyright 2006/2007/2008
|
|
||||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ 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 PSBLAS 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 PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
|
|
||||||
!
|
|
||||||
! Compute Y <- beta*Y + alpha*K^-1 X
|
|
||||||
! where K is a a Block Jacobi preconditioner stored in prec
|
|
||||||
! Note that desc_data may or may not be the same as prec%desc_data,
|
|
||||||
! but since both are INTENT(IN) this should be legal.
|
|
||||||
!
|
|
||||||
|
|
||||||
use psb_base_mod
|
|
||||||
use psb_prec_mod, psb_protect_name => psb_dbjac_aply
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
type(psb_desc_type), intent(in) :: desc_data
|
|
||||||
type(psb_dprec_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
|
|
||||||
real(psb_dpk_), pointer :: ww(:), aux(:)
|
|
||||||
integer :: ictxt,np,me, err_act, int_err(5)
|
|
||||||
integer :: debug_level, debug_unit
|
|
||||||
character :: trans_
|
|
||||||
character(len=20) :: name, ch_err
|
|
||||||
|
|
||||||
name='psb_bjac_aply'
|
|
||||||
info = 0
|
|
||||||
call psb_erractionsave(err_act)
|
|
||||||
debug_unit = psb_get_debug_unit()
|
|
||||||
debug_level = psb_get_debug_level()
|
|
||||||
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
|
|
||||||
call psb_errpush(40,name)
|
|
||||||
goto 9999
|
|
||||||
end select
|
|
||||||
|
|
||||||
|
|
||||||
n_row=desc_data%matrix_data(psb_n_row_)
|
|
||||||
n_col=desc_data%matrix_data(psb_n_col_)
|
|
||||||
|
|
||||||
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 /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Allocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
endif
|
|
||||||
else
|
|
||||||
allocate(ww(n_col),aux(4*n_col),stat=info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Allocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
endif
|
|
||||||
|
|
||||||
|
|
||||||
select case(prec%iprcparm(psb_f_type_))
|
|
||||||
case(psb_f_ilu_n_)
|
|
||||||
|
|
||||||
select case(trans_)
|
|
||||||
case('N')
|
|
||||||
|
|
||||||
call psb_spsm(done,prec%av(psb_l_pr_),x,dzero,ww,desc_data,info,&
|
|
||||||
& trans=trans_,scale='L',diag=prec%d,choice=psb_none_,work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,&
|
|
||||||
& trans=trans_,scale='U',choice=psb_none_, work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
|
|
||||||
case('T','C')
|
|
||||||
call psb_spsm(done,prec%av(psb_u_pr_),x,dzero,ww,desc_data,info,&
|
|
||||||
& trans=trans_,scale='L',diag=prec%d,choice=psb_none_, work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,&
|
|
||||||
& trans=trans_,scale='U',choice=psb_none_,work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
|
|
||||||
end select
|
|
||||||
|
|
||||||
|
|
||||||
case default
|
|
||||||
info = 4001
|
|
||||||
call psb_errpush(info,name,a_err='Invalid factorization')
|
|
||||||
goto 9999
|
|
||||||
end select
|
|
||||||
|
|
||||||
call psb_halo(y,desc_data,info,data=psb_comm_mov_)
|
|
||||||
|
|
||||||
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_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 psb_dbjac_aply
|
|
||||||
@ -1,181 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS version 2.2
|
|
||||||
!!$ (C) Copyright 2006/2007/2008
|
|
||||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ 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 PSBLAS 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 PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
|
|
||||||
use psb_base_mod
|
|
||||||
use psb_prec_mod, psb_protect_name => psb_dbjac_bld
|
|
||||||
implicit none
|
|
||||||
!
|
|
||||||
! .. Scalar Arguments ..
|
|
||||||
integer, intent(out) :: info
|
|
||||||
! .. array Arguments ..
|
|
||||||
type(psb_d_sparse_mat), intent(in), target :: a
|
|
||||||
type(psb_dprec_type), intent(inout) :: p
|
|
||||||
type(psb_desc_type), intent(in) :: desc_a
|
|
||||||
character, intent(in) :: upd
|
|
||||||
|
|
||||||
! .. Local Scalars ..
|
|
||||||
integer :: i, m
|
|
||||||
integer :: int_err(5)
|
|
||||||
character :: trans, unitd
|
|
||||||
type(psb_d_csr_sparse_mat), allocatable :: lf, uf
|
|
||||||
real(psb_dpk_) :: t1,t2,t3,t4,t5,t6, t7, t8
|
|
||||||
integer nztota, err_act, n_row, nrow_a,n_col, nhalo
|
|
||||||
integer :: ictxt,np,me
|
|
||||||
character(len=20) :: name, ch_err
|
|
||||||
|
|
||||||
|
|
||||||
if(psb_get_errstatus() /= 0) return
|
|
||||||
info=0
|
|
||||||
name='psb_dbjac_bld'
|
|
||||||
call psb_erractionsave(err_act)
|
|
||||||
|
|
||||||
ictxt=psb_cd_get_context(desc_a)
|
|
||||||
call psb_info(ictxt, me, np)
|
|
||||||
|
|
||||||
m = a%get_nrows()
|
|
||||||
if (m < 0) then
|
|
||||||
info = 10
|
|
||||||
int_err(1) = 1
|
|
||||||
int_err(2) = m
|
|
||||||
call psb_errpush(info,name,i_err=int_err)
|
|
||||||
goto 9999
|
|
||||||
endif
|
|
||||||
trans = 'N'
|
|
||||||
unitd = 'U'
|
|
||||||
|
|
||||||
call psb_cdcpy(desc_a,p%desc_data,info)
|
|
||||||
if(info /= 0) then
|
|
||||||
info=4010
|
|
||||||
ch_err='psb_cdcpy'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
|
|
||||||
select case(p%iprcparm(psb_f_type_))
|
|
||||||
|
|
||||||
case(psb_f_ilu_n_)
|
|
||||||
|
|
||||||
if (allocated(p%av)) then
|
|
||||||
if (size(p%av) < psb_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(psb_max_avsz),stat=info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4000,name)
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
endif
|
|
||||||
|
|
||||||
nrow_a = psb_cd_get_local_rows(desc_a)
|
|
||||||
nztota = a%get_nzeros()
|
|
||||||
|
|
||||||
n_col = psb_cd_get_local_cols(desc_a)
|
|
||||||
nhalo = n_col-nrow_a
|
|
||||||
n_row = p%desc_data%matrix_data(psb_n_row_)
|
|
||||||
|
|
||||||
allocate(lf,uf,stat=info)
|
|
||||||
if (info == 0) call lf%allocate(n_row,n_row,nztota)
|
|
||||||
if (info == 0) call uf%allocate(n_row,n_row,nztota)
|
|
||||||
|
|
||||||
if(info/=0) then
|
|
||||||
info=4010
|
|
||||||
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 /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Allocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
endif
|
|
||||||
t3 = psb_wtime()
|
|
||||||
! This is where we have no renumbering, thus no need
|
|
||||||
call psb_ilu_fct(a,lf,uf,p%d,info)
|
|
||||||
|
|
||||||
if(info==0) then
|
|
||||||
call p%av(psb_l_pr_)%mv_from(lf)
|
|
||||||
call p%av(psb_u_pr_)%mv_from(uf)
|
|
||||||
call p%av(psb_l_pr_)%set_asb()
|
|
||||||
call p%av(psb_u_pr_)%set_asb()
|
|
||||||
call p%av(psb_l_pr_)%trim()
|
|
||||||
call p%av(psb_u_pr_)%trim()
|
|
||||||
else
|
|
||||||
info=4010
|
|
||||||
ch_err='psb_ilu_fct'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
case(psb_f_none_)
|
|
||||||
info=4010
|
|
||||||
ch_err='Inconsistent prec psb_f_none_'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
goto 9999
|
|
||||||
|
|
||||||
case default
|
|
||||||
info=4010
|
|
||||||
ch_err='Unknown psb_f_type_'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
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 psb_dbjac_bld
|
|
||||||
|
|
||||||
|
|
||||||
@ -1,120 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS version 2.2
|
|
||||||
!!$ (C) Copyright 2006/2007/2008
|
|
||||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ 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 PSBLAS 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 PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info)
|
|
||||||
|
|
||||||
use psb_base_mod
|
|
||||||
use psb_prec_mod, psb_protect_name => psb_ddiagsc_bld
|
|
||||||
Implicit None
|
|
||||||
|
|
||||||
type(psb_d_sparse_mat), intent(in), target :: a
|
|
||||||
type(psb_desc_type), intent(in) :: desc_a
|
|
||||||
type(psb_dprec_type),intent(inout) :: p
|
|
||||||
character, intent(in) :: upd
|
|
||||||
integer, intent(out) :: info
|
|
||||||
|
|
||||||
|
|
||||||
! Local scalars
|
|
||||||
Integer :: err, n_row, n_col,I,ictxt,&
|
|
||||||
& me,np,mglob, err_act
|
|
||||||
integer :: int_err(5)
|
|
||||||
|
|
||||||
integer,parameter :: iroot=psb_root_,iout=60,ilout=40
|
|
||||||
character(len=20) :: name, ch_err
|
|
||||||
|
|
||||||
if(psb_get_errstatus() /= 0) return
|
|
||||||
info=0
|
|
||||||
err=0
|
|
||||||
call psb_erractionsave(err_act)
|
|
||||||
name = 'psb_diagsc_bld'
|
|
||||||
|
|
||||||
info = 0
|
|
||||||
int_err(1) = 0
|
|
||||||
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)
|
|
||||||
|
|
||||||
! diagonal scaling
|
|
||||||
|
|
||||||
call psb_realloc(n_col,p%d,info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='psb_realloc')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
!
|
|
||||||
! Retrieve the diagonal entries of the matrix A
|
|
||||||
!
|
|
||||||
call a%get_diag(p%d,info)
|
|
||||||
if(info /= 0) then
|
|
||||||
info=4010
|
|
||||||
ch_err='psb_sp_getdiag'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
!
|
|
||||||
! Copy into p%desc_data the descriptor associated to A
|
|
||||||
!
|
|
||||||
call psb_cdcpy(desc_a,p%desc_Data,info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='psb_cdcpy')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
!
|
|
||||||
! The i-th diagonal entry of the preconditioner is set to one if the
|
|
||||||
! corresponding entry a_ii of the sparse matrix A is zero; otherwise
|
|
||||||
! it is set to one/a_ii
|
|
||||||
!
|
|
||||||
do i=1,n_row
|
|
||||||
if (p%d(i) == dzero) then
|
|
||||||
p%d(i) = done
|
|
||||||
else
|
|
||||||
p%d(i) = done/p%d(i)
|
|
||||||
endif
|
|
||||||
end do
|
|
||||||
|
|
||||||
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 psb_ddiagsc_bld
|
|
||||||
|
|
||||||
@ -1,135 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS version 2.2
|
|
||||||
!!$ (C) Copyright 2006/2007/2008
|
|
||||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ 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 PSBLAS 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 PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
subroutine psb_dgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
|
|
||||||
!
|
|
||||||
! Compute Y <- beta*Y + alpha*K^-1 X
|
|
||||||
! where K is a a basic preconditioner stored in prec
|
|
||||||
!
|
|
||||||
|
|
||||||
use psb_base_mod
|
|
||||||
use psb_prec_mod, psb_protect_name => psb_dgprec_aply
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
type(psb_desc_type),intent(in) :: desc_data
|
|
||||||
type(psb_dprec_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,int_err(5)
|
|
||||||
real(psb_dpk_), pointer :: ww(:)
|
|
||||||
character :: trans_
|
|
||||||
integer :: ictxt,np,me, err_act
|
|
||||||
character(len=20) :: name, ch_err
|
|
||||||
|
|
||||||
name='psb_dgprec_aply'
|
|
||||||
info = 0
|
|
||||||
call psb_erractionsave(err_act)
|
|
||||||
|
|
||||||
ictxt=desc_data%matrix_data(psb_ctxt_)
|
|
||||||
call psb_info(ictxt, me, np)
|
|
||||||
|
|
||||||
trans_ = psb_toupper(trans)
|
|
||||||
|
|
||||||
select case(trans_)
|
|
||||||
case('N')
|
|
||||||
case('T','C')
|
|
||||||
case default
|
|
||||||
info=40
|
|
||||||
int_err(1)=6
|
|
||||||
ch_err(2:2)=trans
|
|
||||||
goto 9999
|
|
||||||
end select
|
|
||||||
|
|
||||||
select case(prec%iprcparm(psb_p_type_))
|
|
||||||
|
|
||||||
case(psb_noprec_)
|
|
||||||
|
|
||||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
|
||||||
|
|
||||||
case(psb_diag_)
|
|
||||||
|
|
||||||
if (size(work) >= size(x)) then
|
|
||||||
ww => work
|
|
||||||
else
|
|
||||||
allocate(ww(size(x)),stat=info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Allocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
end if
|
|
||||||
|
|
||||||
n_row=desc_data%matrix_data(psb_n_row_)
|
|
||||||
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 /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Deallocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
end if
|
|
||||||
|
|
||||||
case(psb_bjac_)
|
|
||||||
|
|
||||||
call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info)
|
|
||||||
if(info /= 0) then
|
|
||||||
info=4010
|
|
||||||
ch_err='psb_bjac_aply'
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
case default
|
|
||||||
info = 4001
|
|
||||||
call psb_errpush(info,name,a_err='Invalid prectype')
|
|
||||||
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 psb_dgprec_aply
|
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,563 @@
|
|||||||
|
module psb_s_bjacprec
|
||||||
|
use psb_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
type, extends(psb_s_base_prec_type) :: psb_s_bjac_prec_type
|
||||||
|
integer, allocatable :: iprcparm(:)
|
||||||
|
type(psb_s_sparse_mat), allocatable :: av(:)
|
||||||
|
real(psb_spk_), allocatable :: d(:)
|
||||||
|
contains
|
||||||
|
procedure, pass(prec) :: apply => s_bjac_apply
|
||||||
|
procedure, pass(prec) :: precbld => s_bjac_precbld
|
||||||
|
procedure, pass(prec) :: precinit => s_bjac_precinit
|
||||||
|
procedure, pass(prec) :: s_base_precseti => s_bjac_precseti
|
||||||
|
procedure, pass(prec) :: s_base_precsetr => s_bjac_precsetr
|
||||||
|
procedure, pass(prec) :: s_base_precsetc => s_bjac_precsetc
|
||||||
|
procedure, pass(prec) :: precfree => s_bjac_precfree
|
||||||
|
procedure, pass(prec) :: precdescr => s_bjac_precdescr
|
||||||
|
procedure, pass(prec) :: sizeof => s_bjac_sizeof
|
||||||
|
end type psb_s_bjac_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
character(len=15), parameter, private :: &
|
||||||
|
& fact_names(0:2)=(/'None ','ILU(n) ',&
|
||||||
|
& 'ILU(eps) '/)
|
||||||
|
|
||||||
|
contains
|
||||||
|
|
||||||
|
|
||||||
|
subroutine s_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work)
|
||||||
|
use psb_base_mod
|
||||||
|
type(psb_desc_type),intent(in) :: desc_data
|
||||||
|
class(psb_s_bjac_prec_type), intent(in) :: prec
|
||||||
|
real(psb_spk_),intent(in) :: alpha,beta
|
||||||
|
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(:)
|
||||||
|
|
||||||
|
! Local variables
|
||||||
|
integer :: n_row,n_col
|
||||||
|
real(psb_spk_), pointer :: ww(:), aux(:)
|
||||||
|
integer :: ictxt,np,me, err_act, int_err(5)
|
||||||
|
integer :: debug_level, debug_unit
|
||||||
|
character :: trans_
|
||||||
|
character(len=20) :: name='s_bjac_prec_apply'
|
||||||
|
character(len=20) :: ch_err
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
debug_unit = psb_get_debug_unit()
|
||||||
|
debug_level = psb_get_debug_level()
|
||||||
|
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
|
||||||
|
call psb_errpush(40,name)
|
||||||
|
goto 9999
|
||||||
|
end select
|
||||||
|
|
||||||
|
|
||||||
|
n_row = psb_cd_get_local_rows(desc_data)
|
||||||
|
n_col = psb_cd_get_local_cols(desc_data)
|
||||||
|
|
||||||
|
if (size(x) < n_row) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(y) < n_row) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (.not.allocated(prec%d)) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner: D")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(prec%d) < n_row) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner: D")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
|
||||||
|
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 /= 0) then
|
||||||
|
call psb_errpush(4010,name,a_err='Allocate')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
endif
|
||||||
|
else
|
||||||
|
allocate(ww(n_col),aux(4*n_col),stat=info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4010,name,a_err='Allocate')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
select case(prec%iprcparm(psb_f_type_))
|
||||||
|
case(psb_f_ilu_n_)
|
||||||
|
|
||||||
|
select case(trans_)
|
||||||
|
case('N')
|
||||||
|
call psb_spsm(sone,prec%av(psb_l_pr_),x,szero,ww,desc_data,info,&
|
||||||
|
& trans=trans_,scale='L',diag=prec%d,choice=psb_none_,work=aux)
|
||||||
|
if(info ==0) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,&
|
||||||
|
& trans=trans_,scale='U',choice=psb_none_, work=aux)
|
||||||
|
|
||||||
|
case('T','C')
|
||||||
|
call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,ww,desc_data,info,&
|
||||||
|
& trans=trans_,scale='L',diag=prec%d,choice=psb_none_, work=aux)
|
||||||
|
if(info ==0) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,&
|
||||||
|
& trans=trans_,scale='U',choice=psb_none_,work=aux)
|
||||||
|
|
||||||
|
end select
|
||||||
|
if (info /=0) then
|
||||||
|
ch_err="psb_spsm"
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
|
||||||
|
case default
|
||||||
|
info = 4001
|
||||||
|
call psb_errpush(info,name,a_err='Invalid factorization')
|
||||||
|
goto 9999
|
||||||
|
end select
|
||||||
|
|
||||||
|
call psb_halo(y,desc_data,info,data=psb_comm_mov_)
|
||||||
|
|
||||||
|
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_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 s_bjac_apply
|
||||||
|
|
||||||
|
subroutine s_bjac_precinit(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_bjac_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='s_null_precinit'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
call psb_realloc(psb_ifpsz,prec%iprcparm,info)
|
||||||
|
if (info /= 0) then
|
||||||
|
info = 4000
|
||||||
|
call psb_Errpush(info,name)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
prec%iprcparm(:) = 0
|
||||||
|
prec%iprcparm(psb_p_type_) = psb_bjac_
|
||||||
|
prec%iprcparm(psb_f_type_) = psb_f_ilu_n_
|
||||||
|
prec%iprcparm(psb_ilu_fill_in_) = 0
|
||||||
|
|
||||||
|
|
||||||
|
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_bjac_precinit
|
||||||
|
|
||||||
|
|
||||||
|
subroutine s_bjac_precbld(a,desc_a,prec,info,upd)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
use psb_prec_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
type(psb_s_sparse_mat), intent(in), target :: a
|
||||||
|
type(psb_desc_type), intent(in), target :: desc_a
|
||||||
|
class(psb_s_bjac_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
character, intent(in), optional :: upd
|
||||||
|
|
||||||
|
! .. Local Scalars ..
|
||||||
|
integer :: i, m
|
||||||
|
integer :: int_err(5)
|
||||||
|
character :: trans, unitd
|
||||||
|
type(psb_s_csr_sparse_mat), allocatable :: lf, uf
|
||||||
|
integer nztota, err_act, n_row, nrow_a,n_col, nhalo
|
||||||
|
integer :: ictxt,np,me
|
||||||
|
character(len=20) :: name='s_bjac_precbld'
|
||||||
|
character(len=20) :: ch_err
|
||||||
|
|
||||||
|
|
||||||
|
if(psb_get_errstatus() /= 0) return
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
ictxt=psb_cd_get_context(desc_a)
|
||||||
|
call psb_info(ictxt, me, np)
|
||||||
|
|
||||||
|
m = a%get_nrows()
|
||||||
|
if (m < 0) then
|
||||||
|
info = 10
|
||||||
|
int_err(1) = 1
|
||||||
|
int_err(2) = m
|
||||||
|
call psb_errpush(info,name,i_err=int_err)
|
||||||
|
goto 9999
|
||||||
|
endif
|
||||||
|
trans = 'N'
|
||||||
|
unitd = 'U'
|
||||||
|
|
||||||
|
select case(prec%iprcparm(psb_f_type_))
|
||||||
|
|
||||||
|
case(psb_f_ilu_n_)
|
||||||
|
|
||||||
|
if (allocated(prec%av)) then
|
||||||
|
if (size(prec%av) < psb_bp_ilu_avsz) then
|
||||||
|
do i=1,size(prec%av)
|
||||||
|
call prec%av(i)%free()
|
||||||
|
enddo
|
||||||
|
deallocate(prec%av,stat=info)
|
||||||
|
endif
|
||||||
|
end if
|
||||||
|
if (.not.allocated(prec%av)) then
|
||||||
|
allocate(prec%av(psb_max_avsz),stat=info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4000,name)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
endif
|
||||||
|
|
||||||
|
nrow_a = psb_cd_get_local_rows(desc_a)
|
||||||
|
nztota = a%get_nzeros()
|
||||||
|
|
||||||
|
n_col = psb_cd_get_local_cols(desc_a)
|
||||||
|
nhalo = n_col-nrow_a
|
||||||
|
n_row = nrow_a
|
||||||
|
|
||||||
|
allocate(lf,uf,stat=info)
|
||||||
|
if (info == 0) call lf%allocate(n_row,n_row,nztota)
|
||||||
|
if (info == 0) call uf%allocate(n_row,n_row,nztota)
|
||||||
|
|
||||||
|
if(info/=0) then
|
||||||
|
info=4010
|
||||||
|
ch_err='psb_sp_all'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
if (allocated(prec%d)) then
|
||||||
|
if (size(prec%d) < n_row) then
|
||||||
|
deallocate(prec%d)
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
if (.not.allocated(prec%d)) then
|
||||||
|
allocate(prec%d(n_row),stat=info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4010,name,a_err='Allocate')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
endif
|
||||||
|
! This is where we have no renumbering, thus no need
|
||||||
|
call psb_ilu_fct(a,lf,uf,prec%d,info)
|
||||||
|
|
||||||
|
if(info==0) then
|
||||||
|
call prec%av(psb_l_pr_)%mv_from(lf)
|
||||||
|
call prec%av(psb_u_pr_)%mv_from(uf)
|
||||||
|
call prec%av(psb_l_pr_)%set_asb()
|
||||||
|
call prec%av(psb_u_pr_)%set_asb()
|
||||||
|
call prec%av(psb_l_pr_)%trim()
|
||||||
|
call prec%av(psb_u_pr_)%trim()
|
||||||
|
else
|
||||||
|
info=4010
|
||||||
|
ch_err='psb_ilu_fct'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
!!$ call prec%av(psb_l_pr_)%print(30+me)
|
||||||
|
!!$ call prec%av(psb_u_pr_)%print(40+me)
|
||||||
|
!!$ do i=1,n_row
|
||||||
|
!!$ write(50+me,*) i,prec%d(i)
|
||||||
|
!!$ end do
|
||||||
|
|
||||||
|
case(psb_f_none_)
|
||||||
|
info=4010
|
||||||
|
ch_err='Inconsistent prec psb_f_none_'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
goto 9999
|
||||||
|
|
||||||
|
case default
|
||||||
|
info=4010
|
||||||
|
ch_err='Unknown psb_f_type_'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
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_bjac_precbld
|
||||||
|
|
||||||
|
subroutine s_bjac_precseti(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_bjac_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
integer, intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='s_bjac_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
if (.not.allocated(prec%iprcparm)) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
select case(what)
|
||||||
|
case (psb_f_type_)
|
||||||
|
if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then
|
||||||
|
write(0,*) 'WHAT is invalid for current preconditioner ',prec%iprcparm(psb_p_type_),&
|
||||||
|
& 'ignoring user specification'
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
prec%iprcparm(psb_f_type_) = val
|
||||||
|
|
||||||
|
case (psb_ilu_fill_in_)
|
||||||
|
if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.(prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then
|
||||||
|
write(0,*) 'WHAT is invalid for current preconditioner ',prec%iprcparm(psb_p_type_),&
|
||||||
|
& 'ignoring user specification'
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
prec%iprcparm(psb_ilu_fill_in_) = val
|
||||||
|
|
||||||
|
case default
|
||||||
|
write(0,*) 'WHAT is invalid, ignoring user specification'
|
||||||
|
|
||||||
|
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_bjac_precseti
|
||||||
|
|
||||||
|
subroutine s_bjac_precsetr(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_bjac_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
real(psb_spk_), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='s_bjac_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
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_bjac_precsetr
|
||||||
|
|
||||||
|
subroutine s_bjac_precsetc(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_bjac_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
character(len=*), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='s_bjac_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
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_bjac_precsetc
|
||||||
|
|
||||||
|
subroutine s_bjac_precfree(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_bjac_prec_type), intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
|
||||||
|
Integer :: err_act, i
|
||||||
|
character(len=20) :: name='s_bjac_precfree'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
if (allocated(prec%av)) then
|
||||||
|
do i=1,size(prec%av)
|
||||||
|
call prec%av(i)%free()
|
||||||
|
enddo
|
||||||
|
deallocate(prec%av,stat=info)
|
||||||
|
end if
|
||||||
|
if (allocated(prec%d)) then
|
||||||
|
deallocate(prec%d,stat=info)
|
||||||
|
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_bjac_precfree
|
||||||
|
|
||||||
|
|
||||||
|
subroutine s_bjac_precdescr(prec,iout)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_bjac_prec_type), intent(in) :: prec
|
||||||
|
integer, intent(in), optional :: iout
|
||||||
|
|
||||||
|
Integer :: err_act, nrow, info
|
||||||
|
character(len=20) :: name='s_bjac_precdescr'
|
||||||
|
integer :: iout_
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
if (present(iout)) then
|
||||||
|
iout_ = iout
|
||||||
|
else
|
||||||
|
iout_ = 6
|
||||||
|
end if
|
||||||
|
|
||||||
|
if (.not.allocated(prec%iprcparm)) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
write(iout_,*) 'Block Jacobi with: ',&
|
||||||
|
& fact_names(prec%iprcparm(psb_f_type_))
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
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_bjac_precdescr
|
||||||
|
|
||||||
|
function s_bjac_sizeof(prec) result(val)
|
||||||
|
use psb_base_mod
|
||||||
|
class(psb_s_bjac_prec_type), intent(in) :: prec
|
||||||
|
integer(psb_long_int_k_) :: val
|
||||||
|
|
||||||
|
val = 0
|
||||||
|
if (allocated(prec%d)) then
|
||||||
|
val = val + psb_sizeof_sp * size(prec%d)
|
||||||
|
endif
|
||||||
|
if (allocated(prec%av)) then
|
||||||
|
val = val + psb_sizeof(prec%av(psb_l_pr_))
|
||||||
|
val = val + psb_sizeof(prec%av(psb_u_pr_))
|
||||||
|
endif
|
||||||
|
return
|
||||||
|
end function s_bjac_sizeof
|
||||||
|
|
||||||
|
end module psb_s_bjacprec
|
||||||
@ -0,0 +1,352 @@
|
|||||||
|
module psb_s_diagprec
|
||||||
|
use psb_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
type, extends(psb_s_base_prec_type) :: psb_s_diag_prec_type
|
||||||
|
real(psb_spk_), allocatable :: d(:)
|
||||||
|
contains
|
||||||
|
procedure, pass(prec) :: apply => s_diag_apply
|
||||||
|
procedure, pass(prec) :: precbld => s_diag_precbld
|
||||||
|
procedure, pass(prec) :: precinit => s_diag_precinit
|
||||||
|
procedure, pass(prec) :: s_base_precseti => s_diag_precseti
|
||||||
|
procedure, pass(prec) :: s_base_precsetr => s_diag_precsetr
|
||||||
|
procedure, pass(prec) :: s_base_precsetc => s_diag_precsetc
|
||||||
|
procedure, pass(prec) :: precfree => s_diag_precfree
|
||||||
|
procedure, pass(prec) :: precdescr => s_diag_precdescr
|
||||||
|
procedure, pass(prec) :: sizeof => s_diag_sizeof
|
||||||
|
end type psb_s_diag_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
contains
|
||||||
|
|
||||||
|
|
||||||
|
subroutine s_diag_apply(alpha,prec,x,beta,y,desc_data,info,trans,work)
|
||||||
|
use psb_base_mod
|
||||||
|
type(psb_desc_type),intent(in) :: desc_data
|
||||||
|
class(psb_s_diag_prec_type), intent(in) :: prec
|
||||||
|
real(psb_spk_),intent(in) :: x(:)
|
||||||
|
real(psb_spk_),intent(in) :: alpha, beta
|
||||||
|
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, nrow
|
||||||
|
character(len=20) :: name='s_diag_prec_apply'
|
||||||
|
real(psb_spk_), pointer :: ww(:)
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
!
|
||||||
|
! This is the base version and we should throw an error.
|
||||||
|
! Or should it be the DIAG preonditioner???
|
||||||
|
!
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
nrow = psb_cd_get_local_rows(desc_data)
|
||||||
|
if (size(x) < nrow) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(y) < nrow) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (.not.allocated(prec%d)) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner: D")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(prec%d) < nrow) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner: D")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
if (size(work) >= size(x)) then
|
||||||
|
ww => work
|
||||||
|
else
|
||||||
|
allocate(ww(size(x)),stat=info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4025,name,i_err=(/size(x),0,0,0,0/),a_err='real(psb_spk_)')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
end if
|
||||||
|
|
||||||
|
ww(1:nrow) = x(1:nrow)*prec%d(1:nrow)
|
||||||
|
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
|
||||||
|
|
||||||
|
if (size(work) < size(x)) then
|
||||||
|
deallocate(ww,stat=info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4010,name,a_err='Deallocate')
|
||||||
|
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_apply
|
||||||
|
|
||||||
|
subroutine s_diag_precinit(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_diag_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='s_diag_precinit'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
|
||||||
|
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_precinit
|
||||||
|
|
||||||
|
|
||||||
|
subroutine s_diag_precbld(a,desc_a,prec,info,upd)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
type(psb_s_sparse_mat), intent(in), target :: a
|
||||||
|
type(psb_desc_type), intent(in), target :: desc_a
|
||||||
|
class(psb_s_diag_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
character, intent(in), optional :: upd
|
||||||
|
Integer :: err_act, nrow,i
|
||||||
|
character(len=20) :: name='s_diag_precbld'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
nrow = psb_cd_get_local_cols(desc_a)
|
||||||
|
if (allocated(prec%d)) then
|
||||||
|
if (size(prec%d) < nrow) then
|
||||||
|
deallocate(prec%d,stat=info)
|
||||||
|
end if
|
||||||
|
end if
|
||||||
|
if ((info == 0).and.(.not.allocated(prec%d))) then
|
||||||
|
allocate(prec%d(nrow), stat=info)
|
||||||
|
end if
|
||||||
|
if (info /= 0) then
|
||||||
|
info = 4000
|
||||||
|
call psb_errpush(info,name)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
call a%get_diag(prec%d,info)
|
||||||
|
if (info /= 0) then
|
||||||
|
info = 4010
|
||||||
|
call psb_errpush(info,name, a_err='get_diag')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
do i=1,nrow
|
||||||
|
if (prec%d(i) == dzero) then
|
||||||
|
prec%d(i) = done
|
||||||
|
else
|
||||||
|
prec%d(i) = done/prec%d(i)
|
||||||
|
endif
|
||||||
|
end do
|
||||||
|
|
||||||
|
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_precbld
|
||||||
|
|
||||||
|
subroutine s_diag_precseti(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_diag_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
integer, intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='s_diag_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
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_precseti
|
||||||
|
|
||||||
|
subroutine s_diag_precsetr(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_diag_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
real(psb_spk_), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='s_diag_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
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_precsetr
|
||||||
|
|
||||||
|
subroutine s_diag_precsetc(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_diag_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
character(len=*), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='s_diag_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
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_precsetc
|
||||||
|
|
||||||
|
subroutine s_diag_precfree(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_diag_prec_type), intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='s_diag_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
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_precfree
|
||||||
|
|
||||||
|
|
||||||
|
subroutine s_diag_precdescr(prec,iout)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_diag_prec_type), intent(in) :: prec
|
||||||
|
integer, intent(in), optional :: iout
|
||||||
|
|
||||||
|
Integer :: err_act, nrow, info
|
||||||
|
character(len=20) :: name='s_diag_precdescr'
|
||||||
|
|
||||||
|
integer :: iout_
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
if (present(iout)) then
|
||||||
|
iout_ = iout
|
||||||
|
else
|
||||||
|
iout_ = 6
|
||||||
|
end if
|
||||||
|
|
||||||
|
write(iout_,*) 'Diagonal scaling'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
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_precdescr
|
||||||
|
|
||||||
|
function s_diag_sizeof(prec) result(val)
|
||||||
|
use psb_base_mod
|
||||||
|
class(psb_s_diag_prec_type), intent(in) :: prec
|
||||||
|
integer(psb_long_int_k_) :: val
|
||||||
|
|
||||||
|
val = 0
|
||||||
|
val = val + psb_sizeof_sp * size(prec%d)
|
||||||
|
return
|
||||||
|
end function s_diag_sizeof
|
||||||
|
|
||||||
|
end module psb_s_diagprec
|
||||||
@ -0,0 +1,293 @@
|
|||||||
|
module psb_s_nullprec
|
||||||
|
use psb_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
type, extends(psb_s_base_prec_type) :: psb_s_null_prec_type
|
||||||
|
contains
|
||||||
|
procedure, pass(prec) :: apply => s_null_apply
|
||||||
|
procedure, pass(prec) :: precbld => s_null_precbld
|
||||||
|
procedure, pass(prec) :: precinit => s_null_precinit
|
||||||
|
procedure, pass(prec) :: s_base_precseti => s_null_precseti
|
||||||
|
procedure, pass(prec) :: s_base_precsetr => s_null_precsetr
|
||||||
|
procedure, pass(prec) :: s_base_precsetc => s_null_precsetc
|
||||||
|
procedure, pass(prec) :: precfree => s_null_precfree
|
||||||
|
procedure, pass(prec) :: precdescr => s_null_precdescr
|
||||||
|
procedure, pass(prec) :: sizeof => s_null_sizeof
|
||||||
|
end type psb_s_null_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
contains
|
||||||
|
|
||||||
|
|
||||||
|
subroutine s_null_apply(alpha,prec,x,beta,y,desc_data,info,trans,work)
|
||||||
|
use psb_base_mod
|
||||||
|
type(psb_desc_type),intent(in) :: desc_data
|
||||||
|
class(psb_s_null_prec_type), intent(in) :: prec
|
||||||
|
real(psb_spk_),intent(in) :: x(:)
|
||||||
|
real(psb_spk_),intent(in) :: alpha, beta
|
||||||
|
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, nrow
|
||||||
|
character(len=20) :: name='s_null_prec_apply'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
!
|
||||||
|
! This is the base version and we should throw an error.
|
||||||
|
! Or should it be the NULL preonditioner???
|
||||||
|
!
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
nrow = psb_cd_get_local_rows(desc_data)
|
||||||
|
if (size(x) < nrow) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(y) < nrow) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||||
|
if (info /= 0 ) then
|
||||||
|
info = 4010
|
||||||
|
call psb_errpush(infoi,name,a_err="psb_geaxpby")
|
||||||
|
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_null_apply
|
||||||
|
|
||||||
|
|
||||||
|
subroutine s_null_precinit(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_null_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='s_null_precinit'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
|
||||||
|
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_null_precinit
|
||||||
|
|
||||||
|
subroutine s_null_precbld(a,desc_a,prec,info,upd)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
type(psb_s_sparse_mat), intent(in), target :: a
|
||||||
|
type(psb_desc_type), intent(in), target :: desc_a
|
||||||
|
class(psb_s_null_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
character, intent(in), optional :: upd
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='s_null_precbld'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
|
||||||
|
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_null_precbld
|
||||||
|
|
||||||
|
subroutine s_null_precseti(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_null_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
integer, intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='s_null_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
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_null_precseti
|
||||||
|
|
||||||
|
subroutine s_null_precsetr(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_null_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
real(psb_spk_), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='s_null_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
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_null_precsetr
|
||||||
|
|
||||||
|
subroutine s_null_precsetc(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_null_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
character(len=*), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='s_null_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
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_null_precsetc
|
||||||
|
|
||||||
|
subroutine s_null_precfree(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_null_prec_type), intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='s_null_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
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_null_precfree
|
||||||
|
|
||||||
|
|
||||||
|
subroutine s_null_precdescr(prec,iout)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_s_null_prec_type), intent(in) :: prec
|
||||||
|
integer, intent(in), optional :: iout
|
||||||
|
|
||||||
|
Integer :: err_act, nrow, info
|
||||||
|
character(len=20) :: name='s_null_precset'
|
||||||
|
integer :: iout_
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
if (present(iout)) then
|
||||||
|
iout_ = iout
|
||||||
|
else
|
||||||
|
iout_ = 6
|
||||||
|
end if
|
||||||
|
|
||||||
|
write(iout_,*) 'No preconditioning'
|
||||||
|
|
||||||
|
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_null_precdescr
|
||||||
|
|
||||||
|
function s_null_sizeof(prec) result(val)
|
||||||
|
use psb_base_mod
|
||||||
|
class(psb_s_null_prec_type), intent(in) :: prec
|
||||||
|
integer(psb_long_int_k_) :: val
|
||||||
|
|
||||||
|
val = 0
|
||||||
|
|
||||||
|
return
|
||||||
|
end function s_null_sizeof
|
||||||
|
|
||||||
|
end module psb_s_nullprec
|
||||||
@ -1,158 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS version 2.2
|
|
||||||
!!$ (C) Copyright 2006/2007/2008
|
|
||||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ 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 PSBLAS 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 PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
subroutine psb_sbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
|
|
||||||
!
|
|
||||||
! Compute Y <- beta*Y + alpha*K^-1 X
|
|
||||||
! where K is a a Block Jacobi preconditioner stored in prec
|
|
||||||
! Note that desc_data may or may not be the same as prec%desc_data,
|
|
||||||
! but since both are INTENT(IN) this should be legal.
|
|
||||||
!
|
|
||||||
|
|
||||||
use psb_base_mod
|
|
||||||
use psb_prec_mod, psb_protect_name => psb_sbjac_aply
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
type(psb_desc_type), intent(in) :: desc_data
|
|
||||||
type(psb_sprec_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
|
|
||||||
real(psb_spk_), pointer :: ww(:), aux(:)
|
|
||||||
integer :: ictxt,np,me, err_act, int_err(5)
|
|
||||||
integer :: debug_level, debug_unit
|
|
||||||
character :: trans_
|
|
||||||
character(len=20) :: name, ch_err
|
|
||||||
|
|
||||||
name='psb_bjac_aply'
|
|
||||||
info = 0
|
|
||||||
call psb_erractionsave(err_act)
|
|
||||||
debug_unit = psb_get_debug_unit()
|
|
||||||
debug_level = psb_get_debug_level()
|
|
||||||
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
|
|
||||||
call psb_errpush(40,name)
|
|
||||||
goto 9999
|
|
||||||
end select
|
|
||||||
|
|
||||||
|
|
||||||
n_row=desc_data%matrix_data(psb_n_row_)
|
|
||||||
n_col=desc_data%matrix_data(psb_n_col_)
|
|
||||||
|
|
||||||
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 /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Allocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
endif
|
|
||||||
else
|
|
||||||
allocate(ww(n_col),aux(4*n_col),stat=info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Allocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
endif
|
|
||||||
|
|
||||||
|
|
||||||
select case(prec%iprcparm(psb_f_type_))
|
|
||||||
case(psb_f_ilu_n_)
|
|
||||||
|
|
||||||
select case(trans_)
|
|
||||||
case('N')
|
|
||||||
|
|
||||||
call psb_spsm(sone,prec%av(psb_l_pr_),x,szero,ww,desc_data,info,&
|
|
||||||
& trans=trans_,scale='L',diag=prec%d,choice=psb_none_,work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,&
|
|
||||||
& trans=trans_,scale='U',choice=psb_none_, work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
|
|
||||||
case('T','C')
|
|
||||||
call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,ww,desc_data,info,&
|
|
||||||
& trans=trans_,scale='L',diag=prec%d,choice=psb_none_, work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,&
|
|
||||||
& trans=trans_,scale='U',choice=psb_none_,work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
|
|
||||||
end select
|
|
||||||
|
|
||||||
|
|
||||||
case default
|
|
||||||
info = 4001
|
|
||||||
call psb_errpush(info,name,a_err='Invalid factorization')
|
|
||||||
goto 9999
|
|
||||||
end select
|
|
||||||
|
|
||||||
call psb_halo(y,desc_data,info,data=psb_comm_mov_)
|
|
||||||
|
|
||||||
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_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 psb_sbjac_aply
|
|
||||||
@ -1,181 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS version 2.2
|
|
||||||
!!$ (C) Copyright 2006/2007/2008
|
|
||||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ 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 PSBLAS 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 PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
subroutine psb_sbjac_bld(a,desc_a,p,upd,info)
|
|
||||||
use psb_base_mod
|
|
||||||
use psb_prec_mod, psb_protect_name => psb_sbjac_bld
|
|
||||||
implicit none
|
|
||||||
!
|
|
||||||
! .. Scalar Arguments ..
|
|
||||||
integer, intent(out) :: info
|
|
||||||
! .. array Arguments ..
|
|
||||||
type(psb_s_sparse_mat), intent(in), target :: a
|
|
||||||
type(psb_sprec_type), intent(inout) :: p
|
|
||||||
type(psb_desc_type), intent(in) :: desc_a
|
|
||||||
character, intent(in) :: upd
|
|
||||||
|
|
||||||
! .. Local Scalars ..
|
|
||||||
integer :: i, m
|
|
||||||
integer :: int_err(5)
|
|
||||||
character :: trans, unitd
|
|
||||||
type(psb_s_csr_sparse_mat), allocatable :: lf, uf
|
|
||||||
real(psb_dpk_) :: t1,t2,t3,t4,t5,t6, t7, t8
|
|
||||||
integer nztota, err_act, n_row, nrow_a,n_col, nhalo
|
|
||||||
integer :: ictxt,np,me
|
|
||||||
character(len=20) :: name, ch_err
|
|
||||||
|
|
||||||
|
|
||||||
if(psb_get_errstatus() /= 0) return
|
|
||||||
info=0
|
|
||||||
name='psb_sbjac_bld'
|
|
||||||
call psb_erractionsave(err_act)
|
|
||||||
|
|
||||||
ictxt=psb_cd_get_context(desc_a)
|
|
||||||
call psb_info(ictxt, me, np)
|
|
||||||
|
|
||||||
m = a%get_nrows()
|
|
||||||
if (m < 0) then
|
|
||||||
info = 10
|
|
||||||
int_err(1) = 1
|
|
||||||
int_err(2) = m
|
|
||||||
call psb_errpush(info,name,i_err=int_err)
|
|
||||||
goto 9999
|
|
||||||
endif
|
|
||||||
trans = 'N'
|
|
||||||
unitd = 'U'
|
|
||||||
|
|
||||||
call psb_cdcpy(desc_a,p%desc_data,info)
|
|
||||||
if(info /= 0) then
|
|
||||||
info=4010
|
|
||||||
ch_err='psb_cdcpy'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
|
|
||||||
select case(p%iprcparm(psb_f_type_))
|
|
||||||
|
|
||||||
case(psb_f_ilu_n_)
|
|
||||||
|
|
||||||
if (allocated(p%av)) then
|
|
||||||
if (size(p%av) < psb_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(psb_max_avsz),stat=info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4000,name)
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
endif
|
|
||||||
|
|
||||||
nrow_a = psb_cd_get_local_rows(desc_a)
|
|
||||||
nztota = a%get_nzeros()
|
|
||||||
|
|
||||||
n_col = psb_cd_get_local_cols(desc_a)
|
|
||||||
nhalo = n_col-nrow_a
|
|
||||||
n_row = p%desc_data%matrix_data(psb_n_row_)
|
|
||||||
|
|
||||||
allocate(lf,uf,stat=info)
|
|
||||||
if (info == 0) call lf%allocate(n_row,n_row,nztota)
|
|
||||||
if (info == 0) call uf%allocate(n_row,n_row,nztota)
|
|
||||||
|
|
||||||
if(info/=0) then
|
|
||||||
info=4010
|
|
||||||
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 /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Allocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
endif
|
|
||||||
t3 = psb_wtime()
|
|
||||||
! This is where we have no renumbering, thus no need
|
|
||||||
call psb_ilu_fct(a,lf,uf,p%d,info)
|
|
||||||
|
|
||||||
if(info==0) then
|
|
||||||
call p%av(psb_l_pr_)%mv_from(lf)
|
|
||||||
call p%av(psb_u_pr_)%mv_from(uf)
|
|
||||||
call p%av(psb_l_pr_)%set_asb()
|
|
||||||
call p%av(psb_u_pr_)%set_asb()
|
|
||||||
call p%av(psb_l_pr_)%trim()
|
|
||||||
call p%av(psb_u_pr_)%trim()
|
|
||||||
else
|
|
||||||
info=4010
|
|
||||||
ch_err='psb_ilu_fct'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
case(psb_f_none_)
|
|
||||||
info=4010
|
|
||||||
ch_err='Inconsistent prec psb_f_none_'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
goto 9999
|
|
||||||
|
|
||||||
case default
|
|
||||||
info=4010
|
|
||||||
ch_err='Unknown psb_f_type_'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
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 psb_sbjac_bld
|
|
||||||
|
|
||||||
|
|
||||||
@ -1,120 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS version 2.2
|
|
||||||
!!$ (C) Copyright 2006/2007/2008
|
|
||||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ 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 PSBLAS 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 PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
subroutine psb_sdiagsc_bld(a,desc_a,p,upd,info)
|
|
||||||
|
|
||||||
use psb_base_mod
|
|
||||||
use psb_prec_mod, psb_protect_name => psb_sdiagsc_bld
|
|
||||||
Implicit None
|
|
||||||
|
|
||||||
type(psb_s_sparse_mat), intent(in), target :: a
|
|
||||||
type(psb_desc_type), intent(in) :: desc_a
|
|
||||||
type(psb_sprec_type),intent(inout) :: p
|
|
||||||
character, intent(in) :: upd
|
|
||||||
integer, intent(out) :: info
|
|
||||||
|
|
||||||
|
|
||||||
! Local scalars
|
|
||||||
Integer :: err, n_row, n_col,I,ictxt,&
|
|
||||||
& me,np,mglob, err_act
|
|
||||||
integer :: int_err(5)
|
|
||||||
|
|
||||||
integer,parameter :: iroot=psb_root_,iout=60,ilout=40
|
|
||||||
character(len=20) :: name, ch_err
|
|
||||||
|
|
||||||
if(psb_get_errstatus() /= 0) return
|
|
||||||
info=0
|
|
||||||
err=0
|
|
||||||
call psb_erractionsave(err_act)
|
|
||||||
name = 'psb_diagsc_bld'
|
|
||||||
|
|
||||||
info = 0
|
|
||||||
int_err(1) = 0
|
|
||||||
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)
|
|
||||||
|
|
||||||
! diagonal scaling
|
|
||||||
|
|
||||||
call psb_realloc(n_col,p%d,info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='psb_realloc')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
!
|
|
||||||
! Retrieve the diagonal entries of the matrix A
|
|
||||||
!
|
|
||||||
call a%get_diag(p%d,info)
|
|
||||||
if(info /= 0) then
|
|
||||||
info=4010
|
|
||||||
ch_err='psb_sp_getdiag'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
!
|
|
||||||
! Copy into p%desc_data the descriptor associated to A
|
|
||||||
!
|
|
||||||
call psb_cdcpy(desc_a,p%desc_Data,info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='psb_cdcpy')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
!
|
|
||||||
! The i-th diagonal entry of the preconditioner is set to one if the
|
|
||||||
! corresponding entry a_ii of the sparse matrix A is zero; otherwise
|
|
||||||
! it is set to one/a_ii
|
|
||||||
!
|
|
||||||
do i=1,n_row
|
|
||||||
if (p%d(i) == szero) then
|
|
||||||
p%d(i) = sone
|
|
||||||
else
|
|
||||||
p%d(i) = sone/p%d(i)
|
|
||||||
endif
|
|
||||||
end do
|
|
||||||
|
|
||||||
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 psb_sdiagsc_bld
|
|
||||||
|
|
||||||
@ -1,135 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS version 2.2
|
|
||||||
!!$ (C) Copyright 2006/2007/2008
|
|
||||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ 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 PSBLAS 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 PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
subroutine psb_sgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
|
|
||||||
!
|
|
||||||
! Compute Y <- beta*Y + alpha*K^-1 X
|
|
||||||
! where K is a a basic preconditioner stored in prec
|
|
||||||
!
|
|
||||||
|
|
||||||
use psb_base_mod
|
|
||||||
use psb_prec_mod, psb_protect_name => psb_sgprec_aply
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
type(psb_desc_type),intent(in) :: desc_data
|
|
||||||
type(psb_sprec_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,int_err(5)
|
|
||||||
real(psb_spk_), pointer :: ww(:)
|
|
||||||
character :: trans_
|
|
||||||
integer :: ictxt,np,me, err_act
|
|
||||||
character(len=20) :: name, ch_err
|
|
||||||
|
|
||||||
name='psb_sgprec_aply'
|
|
||||||
info = 0
|
|
||||||
call psb_erractionsave(err_act)
|
|
||||||
|
|
||||||
ictxt=desc_data%matrix_data(psb_ctxt_)
|
|
||||||
call psb_info(ictxt, me, np)
|
|
||||||
|
|
||||||
trans_ = psb_toupper(trans)
|
|
||||||
|
|
||||||
select case(trans_)
|
|
||||||
case('N')
|
|
||||||
case('T','C')
|
|
||||||
case default
|
|
||||||
info=40
|
|
||||||
int_err(1)=6
|
|
||||||
ch_err(2:2)=trans
|
|
||||||
goto 9999
|
|
||||||
end select
|
|
||||||
|
|
||||||
select case(prec%iprcparm(psb_p_type_))
|
|
||||||
|
|
||||||
case(psb_noprec_)
|
|
||||||
|
|
||||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
|
||||||
|
|
||||||
case(psb_diag_)
|
|
||||||
|
|
||||||
if (size(work) >= size(x)) then
|
|
||||||
ww => work
|
|
||||||
else
|
|
||||||
allocate(ww(size(x)),stat=info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Allocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
end if
|
|
||||||
|
|
||||||
n_row=desc_data%matrix_data(psb_n_row_)
|
|
||||||
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 /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Deallocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
end if
|
|
||||||
|
|
||||||
case(psb_bjac_)
|
|
||||||
|
|
||||||
call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info)
|
|
||||||
if(info /= 0) then
|
|
||||||
info=4010
|
|
||||||
ch_err='psb_bjac_aply'
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
case default
|
|
||||||
info = 4001
|
|
||||||
call psb_errpush(info,name,a_err='Invalid prectype')
|
|
||||||
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 psb_sgprec_aply
|
|
||||||
|
|
||||||
@ -0,0 +1,569 @@
|
|||||||
|
module psb_z_bjacprec
|
||||||
|
use psb_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
type, extends(psb_z_base_prec_type) :: psb_z_bjac_prec_type
|
||||||
|
integer, allocatable :: iprcparm(:)
|
||||||
|
type(psb_z_sparse_mat), allocatable :: av(:)
|
||||||
|
complex(psb_dpk_), allocatable :: d(:)
|
||||||
|
contains
|
||||||
|
procedure, pass(prec) :: apply => z_bjac_apply
|
||||||
|
procedure, pass(prec) :: precbld => z_bjac_precbld
|
||||||
|
procedure, pass(prec) :: precinit => z_bjac_precinit
|
||||||
|
procedure, pass(prec) :: z_base_precseti => z_bjac_precseti
|
||||||
|
procedure, pass(prec) :: z_base_precsetr => z_bjac_precsetr
|
||||||
|
procedure, pass(prec) :: z_base_precsetc => z_bjac_precsetc
|
||||||
|
procedure, pass(prec) :: precfree => z_bjac_precfree
|
||||||
|
procedure, pass(prec) :: precdescr => z_bjac_precdescr
|
||||||
|
procedure, pass(prec) :: sizeof => z_bjac_sizeof
|
||||||
|
end type psb_z_bjac_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
character(len=15), parameter, private :: &
|
||||||
|
& fact_names(0:2)=(/'None ','ILU(n) ',&
|
||||||
|
& 'ILU(eps) '/)
|
||||||
|
|
||||||
|
contains
|
||||||
|
|
||||||
|
|
||||||
|
subroutine z_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work)
|
||||||
|
use psb_base_mod
|
||||||
|
type(psb_desc_type),intent(in) :: desc_data
|
||||||
|
class(psb_z_bjac_prec_type), intent(in) :: prec
|
||||||
|
complex(psb_dpk_),intent(in) :: alpha,beta
|
||||||
|
complex(psb_dpk_),intent(in) :: x(:)
|
||||||
|
complex(psb_dpk_),intent(inout) :: y(:)
|
||||||
|
integer, intent(out) :: info
|
||||||
|
character(len=1), optional :: trans
|
||||||
|
complex(psb_dpk_),intent(inout), optional, target :: work(:)
|
||||||
|
|
||||||
|
! Local variables
|
||||||
|
integer :: n_row,n_col
|
||||||
|
complex(psb_dpk_), pointer :: ww(:), aux(:)
|
||||||
|
integer :: ictxt,np,me, err_act, int_err(5)
|
||||||
|
integer :: debug_level, debug_unit
|
||||||
|
character :: trans_
|
||||||
|
character(len=20) :: name='z_bjac_prec_apply'
|
||||||
|
character(len=20) :: ch_err
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
debug_unit = psb_get_debug_unit()
|
||||||
|
debug_level = psb_get_debug_level()
|
||||||
|
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
|
||||||
|
call psb_errpush(40,name)
|
||||||
|
goto 9999
|
||||||
|
end select
|
||||||
|
|
||||||
|
|
||||||
|
n_row = psb_cd_get_local_rows(desc_data)
|
||||||
|
n_col = psb_cd_get_local_cols(desc_data)
|
||||||
|
|
||||||
|
if (size(x) < n_row) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/2,n_row,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(y) < n_row) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/3,n_row,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (.not.allocated(prec%d)) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner: D")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(prec%d) < n_row) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner: D")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
|
||||||
|
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 /= 0) then
|
||||||
|
call psb_errpush(4010,name,a_err='Allocate')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
endif
|
||||||
|
else
|
||||||
|
allocate(ww(n_col),aux(4*n_col),stat=info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4010,name,a_err='Allocate')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
endif
|
||||||
|
|
||||||
|
|
||||||
|
select case(prec%iprcparm(psb_f_type_))
|
||||||
|
case(psb_f_ilu_n_)
|
||||||
|
|
||||||
|
select case(trans_)
|
||||||
|
case('N')
|
||||||
|
call psb_spsm(zone,prec%av(psb_l_pr_),x,zzero,ww,desc_data,info,&
|
||||||
|
& trans=trans_,scale='L',diag=prec%d,choice=psb_none_,work=aux)
|
||||||
|
if(info ==0) call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,&
|
||||||
|
& trans=trans_,scale='U',choice=psb_none_, work=aux)
|
||||||
|
|
||||||
|
case('T')
|
||||||
|
call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,ww,desc_data,info,&
|
||||||
|
& trans=trans_,scale='L',diag=prec%d,choice=psb_none_, work=aux)
|
||||||
|
if(info ==0) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,&
|
||||||
|
& trans=trans_,scale='U',choice=psb_none_,work=aux)
|
||||||
|
|
||||||
|
case('C')
|
||||||
|
call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,ww,desc_data,info,&
|
||||||
|
& trans=trans_,scale='L',diag=conjg(prec%d),choice=psb_none_, work=aux)
|
||||||
|
if(info ==0) call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,&
|
||||||
|
& trans=trans_,scale='U',choice=psb_none_,work=aux)
|
||||||
|
|
||||||
|
end select
|
||||||
|
if (info /=0) then
|
||||||
|
ch_err="psb_spsm"
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
|
||||||
|
case default
|
||||||
|
info = 4001
|
||||||
|
call psb_errpush(info,name,a_err='Invalid factorization')
|
||||||
|
goto 9999
|
||||||
|
end select
|
||||||
|
|
||||||
|
call psb_halo(y,desc_data,info,data=psb_comm_mov_)
|
||||||
|
|
||||||
|
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_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 z_bjac_apply
|
||||||
|
|
||||||
|
subroutine z_bjac_precinit(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_bjac_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='z_bjac_precinit'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
call psb_realloc(psb_ifpsz,prec%iprcparm,info)
|
||||||
|
if (info /= 0) then
|
||||||
|
info = 4000
|
||||||
|
call psb_Errpush(info,name)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
prec%iprcparm(:) = 0
|
||||||
|
prec%iprcparm(psb_p_type_) = psb_bjac_
|
||||||
|
prec%iprcparm(psb_f_type_) = psb_f_ilu_n_
|
||||||
|
prec%iprcparm(psb_ilu_fill_in_) = 0
|
||||||
|
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine z_bjac_precinit
|
||||||
|
|
||||||
|
|
||||||
|
subroutine z_bjac_precbld(a,desc_a,prec,info,upd)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
use psb_prec_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
type(psb_z_sparse_mat), intent(in), target :: a
|
||||||
|
type(psb_desc_type), intent(in), target :: desc_a
|
||||||
|
class(psb_z_bjac_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
character, intent(in), optional :: upd
|
||||||
|
|
||||||
|
! .. Local Scalars ..
|
||||||
|
integer :: i, m
|
||||||
|
integer :: int_err(5)
|
||||||
|
character :: trans, unitd
|
||||||
|
type(psb_z_csr_sparse_mat), allocatable :: lf, uf
|
||||||
|
integer nztota, err_act, n_row, nrow_a,n_col, nhalo
|
||||||
|
integer :: ictxt,np,me
|
||||||
|
character(len=20) :: name='z_bjac_precbld'
|
||||||
|
character(len=20) :: ch_err
|
||||||
|
|
||||||
|
|
||||||
|
if(psb_get_errstatus() /= 0) return
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
ictxt=psb_cd_get_context(desc_a)
|
||||||
|
call psb_info(ictxt, me, np)
|
||||||
|
|
||||||
|
m = a%get_nrows()
|
||||||
|
if (m < 0) then
|
||||||
|
info = 10
|
||||||
|
int_err(1) = 1
|
||||||
|
int_err(2) = m
|
||||||
|
call psb_errpush(info,name,i_err=int_err)
|
||||||
|
goto 9999
|
||||||
|
endif
|
||||||
|
trans = 'N'
|
||||||
|
unitd = 'U'
|
||||||
|
|
||||||
|
select case(prec%iprcparm(psb_f_type_))
|
||||||
|
|
||||||
|
case(psb_f_ilu_n_)
|
||||||
|
|
||||||
|
if (allocated(prec%av)) then
|
||||||
|
if (size(prec%av) < psb_bp_ilu_avsz) then
|
||||||
|
do i=1,size(prec%av)
|
||||||
|
call prec%av(i)%free()
|
||||||
|
enddo
|
||||||
|
deallocate(prec%av,stat=info)
|
||||||
|
endif
|
||||||
|
end if
|
||||||
|
if (.not.allocated(prec%av)) then
|
||||||
|
allocate(prec%av(psb_max_avsz),stat=info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4000,name)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
endif
|
||||||
|
|
||||||
|
nrow_a = psb_cd_get_local_rows(desc_a)
|
||||||
|
nztota = a%get_nzeros()
|
||||||
|
|
||||||
|
n_col = psb_cd_get_local_cols(desc_a)
|
||||||
|
nhalo = n_col-nrow_a
|
||||||
|
n_row = nrow_a
|
||||||
|
|
||||||
|
allocate(lf,uf,stat=info)
|
||||||
|
if (info == 0) call lf%allocate(n_row,n_row,nztota)
|
||||||
|
if (info == 0) call uf%allocate(n_row,n_row,nztota)
|
||||||
|
|
||||||
|
if(info/=0) then
|
||||||
|
info=4010
|
||||||
|
ch_err='psb_sp_all'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
if (allocated(prec%d)) then
|
||||||
|
if (size(prec%d) < n_row) then
|
||||||
|
deallocate(prec%d)
|
||||||
|
endif
|
||||||
|
endif
|
||||||
|
if (.not.allocated(prec%d)) then
|
||||||
|
allocate(prec%d(n_row),stat=info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4010,name,a_err='Allocate')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
endif
|
||||||
|
! This is where we have no renumbering, thus no need
|
||||||
|
call psb_ilu_fct(a,lf,uf,prec%d,info)
|
||||||
|
|
||||||
|
if(info==0) then
|
||||||
|
call prec%av(psb_l_pr_)%mv_from(lf)
|
||||||
|
call prec%av(psb_u_pr_)%mv_from(uf)
|
||||||
|
call prec%av(psb_l_pr_)%set_asb()
|
||||||
|
call prec%av(psb_u_pr_)%set_asb()
|
||||||
|
call prec%av(psb_l_pr_)%trim()
|
||||||
|
call prec%av(psb_u_pr_)%trim()
|
||||||
|
else
|
||||||
|
info=4010
|
||||||
|
ch_err='psb_ilu_fct'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
!!$ call prec%av(psb_l_pr_)%print(30+me)
|
||||||
|
!!$ call prec%av(psb_u_pr_)%print(40+me)
|
||||||
|
!!$ do i=1,n_row
|
||||||
|
!!$ write(50+me,*) i,prec%d(i)
|
||||||
|
!!$ end do
|
||||||
|
|
||||||
|
case(psb_f_none_)
|
||||||
|
info=4010
|
||||||
|
ch_err='Inconsistent prec psb_f_none_'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
goto 9999
|
||||||
|
|
||||||
|
case default
|
||||||
|
info=4010
|
||||||
|
ch_err='Unknown psb_f_type_'
|
||||||
|
call psb_errpush(info,name,a_err=ch_err)
|
||||||
|
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 z_bjac_precbld
|
||||||
|
|
||||||
|
subroutine z_bjac_precseti(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_bjac_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
integer, intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='z_bjac_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
if (.not.allocated(prec%iprcparm)) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
select case(what)
|
||||||
|
case (psb_f_type_)
|
||||||
|
if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then
|
||||||
|
write(0,*) 'WHAT is invalid for current preconditioner ',prec%iprcparm(psb_p_type_),&
|
||||||
|
& 'ignoring user specification'
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
prec%iprcparm(psb_f_type_) = val
|
||||||
|
|
||||||
|
case (psb_ilu_fill_in_)
|
||||||
|
if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.(prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then
|
||||||
|
write(0,*) 'WHAT is invalid for current preconditioner ',prec%iprcparm(psb_p_type_),&
|
||||||
|
& 'ignoring user specification'
|
||||||
|
return
|
||||||
|
endif
|
||||||
|
prec%iprcparm(psb_ilu_fill_in_) = val
|
||||||
|
|
||||||
|
case default
|
||||||
|
write(0,*) 'WHAT is invalid, ignoring user specification'
|
||||||
|
|
||||||
|
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 z_bjac_precseti
|
||||||
|
|
||||||
|
subroutine z_bjac_precsetr(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_bjac_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
real(psb_dpk_), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='z_bjac_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine z_bjac_precsetr
|
||||||
|
|
||||||
|
subroutine z_bjac_precsetc(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_bjac_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
character(len=*), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='c_bjac_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine z_bjac_precsetc
|
||||||
|
|
||||||
|
subroutine z_bjac_precfree(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_bjac_prec_type), intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
|
||||||
|
Integer :: err_act, i
|
||||||
|
character(len=20) :: name='z_bjac_precfree'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
if (allocated(prec%av)) then
|
||||||
|
do i=1,size(prec%av)
|
||||||
|
call prec%av(i)%free()
|
||||||
|
enddo
|
||||||
|
deallocate(prec%av,stat=info)
|
||||||
|
end if
|
||||||
|
if (allocated(prec%d)) then
|
||||||
|
deallocate(prec%d,stat=info)
|
||||||
|
end if
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
|
||||||
|
end subroutine z_bjac_precfree
|
||||||
|
|
||||||
|
|
||||||
|
subroutine z_bjac_precdescr(prec,iout)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_bjac_prec_type), intent(in) :: prec
|
||||||
|
integer, intent(in), optional :: iout
|
||||||
|
|
||||||
|
Integer :: err_act, nrow, info
|
||||||
|
character(len=20) :: name='z_bjac_precdescr'
|
||||||
|
integer :: iout_
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
if (present(iout)) then
|
||||||
|
iout_ = iout
|
||||||
|
else
|
||||||
|
iout_ = 6
|
||||||
|
end if
|
||||||
|
|
||||||
|
if (.not.allocated(prec%iprcparm)) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
write(iout_,*) 'Block Jacobi with: ',&
|
||||||
|
& fact_names(prec%iprcparm(psb_f_type_))
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
|
||||||
|
end subroutine z_bjac_precdescr
|
||||||
|
|
||||||
|
function z_bjac_sizeof(prec) result(val)
|
||||||
|
use psb_base_mod
|
||||||
|
class(psb_z_bjac_prec_type), intent(in) :: prec
|
||||||
|
integer(psb_long_int_k_) :: val
|
||||||
|
|
||||||
|
val = 0
|
||||||
|
if (allocated(prec%d)) then
|
||||||
|
val = val + 2*psb_sizeof_dp * size(prec%d)
|
||||||
|
endif
|
||||||
|
if (allocated(prec%av)) then
|
||||||
|
val = val + psb_sizeof(prec%av(psb_l_pr_))
|
||||||
|
val = val + psb_sizeof(prec%av(psb_u_pr_))
|
||||||
|
endif
|
||||||
|
return
|
||||||
|
end function z_bjac_sizeof
|
||||||
|
|
||||||
|
end module psb_z_bjacprec
|
||||||
@ -0,0 +1,375 @@
|
|||||||
|
module psb_z_diagprec
|
||||||
|
use psb_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
type, extends(psb_z_base_prec_type) :: psb_z_diag_prec_type
|
||||||
|
complex(psb_dpk_), allocatable :: d(:)
|
||||||
|
contains
|
||||||
|
procedure, pass(prec) :: apply => z_diag_apply
|
||||||
|
procedure, pass(prec) :: precbld => z_diag_precbld
|
||||||
|
procedure, pass(prec) :: precinit => z_diag_precinit
|
||||||
|
procedure, pass(prec) :: z_base_precseti => z_diag_precseti
|
||||||
|
procedure, pass(prec) :: z_base_precsetr => z_diag_precsetr
|
||||||
|
procedure, pass(prec) :: z_base_precsetc => z_diag_precsetc
|
||||||
|
procedure, pass(prec) :: precfree => z_diag_precfree
|
||||||
|
procedure, pass(prec) :: precdescr => z_diag_precdescr
|
||||||
|
procedure, pass(prec) :: sizeof => z_diag_sizeof
|
||||||
|
end type psb_z_diag_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
contains
|
||||||
|
|
||||||
|
|
||||||
|
subroutine z_diag_apply(alpha,prec,x,beta,y,desc_data,info,trans,work)
|
||||||
|
use psb_base_mod
|
||||||
|
type(psb_desc_type),intent(in) :: desc_data
|
||||||
|
class(psb_z_diag_prec_type), intent(in) :: prec
|
||||||
|
complex(psb_dpk_),intent(in) :: x(:)
|
||||||
|
complex(psb_dpk_),intent(in) :: alpha, beta
|
||||||
|
complex(psb_dpk_),intent(inout) :: y(:)
|
||||||
|
integer, intent(out) :: info
|
||||||
|
character(len=1), optional :: trans
|
||||||
|
complex(psb_dpk_),intent(inout), optional, target :: work(:)
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character :: trans_
|
||||||
|
character(len=20) :: name='z_diag_prec_apply'
|
||||||
|
complex(psb_dpk_), pointer :: ww(:)
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
!
|
||||||
|
! This is the base version and we should throw an error.
|
||||||
|
! Or should it be the DIAG preonditioner???
|
||||||
|
!
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
|
||||||
|
nrow = psb_cd_get_local_rows(desc_data)
|
||||||
|
if (size(x) < nrow) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(y) < nrow) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (.not.allocated(prec%d)) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner: D")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(prec%d) < nrow) then
|
||||||
|
info = 1124
|
||||||
|
call psb_errpush(info,name,a_err="preconditioner: D")
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (present(trans)) then
|
||||||
|
trans_ = psb_toupper(trans)
|
||||||
|
else
|
||||||
|
trans_='N'
|
||||||
|
end if
|
||||||
|
|
||||||
|
select case(trans_)
|
||||||
|
case('N')
|
||||||
|
case('T','C')
|
||||||
|
case default
|
||||||
|
info=40
|
||||||
|
call psb_errpush(info,name,&
|
||||||
|
& i_err=(/6,0,0,0,0/),a_err=trans_)
|
||||||
|
goto 9999
|
||||||
|
end select
|
||||||
|
|
||||||
|
if (size(work) >= size(x)) then
|
||||||
|
ww => work
|
||||||
|
else
|
||||||
|
allocate(ww(size(x)),stat=info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4025,name,&
|
||||||
|
& i_err=(/size(x),0,0,0,0/),a_err='complex(psb_dpk_)')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
end if
|
||||||
|
|
||||||
|
|
||||||
|
if (trans_=='C') then
|
||||||
|
ww(1:nrow) = x(1:nrow)*conjg(prec%d(1:nrow))
|
||||||
|
else
|
||||||
|
ww(1:nrow) = x(1:nrow)*prec%d(1:nrow)
|
||||||
|
endif
|
||||||
|
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
|
||||||
|
|
||||||
|
if (size(work) < size(x)) then
|
||||||
|
deallocate(ww,stat=info)
|
||||||
|
if (info /= 0) then
|
||||||
|
call psb_errpush(4010,name,a_err='Deallocate')
|
||||||
|
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 z_diag_apply
|
||||||
|
|
||||||
|
subroutine z_diag_precinit(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_diag_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='z_diag_precinit'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine z_diag_precinit
|
||||||
|
|
||||||
|
|
||||||
|
subroutine z_diag_precbld(a,desc_a,prec,info,upd)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
type(psb_z_sparse_mat), intent(in), target :: a
|
||||||
|
type(psb_desc_type), intent(in), target :: desc_a
|
||||||
|
class(psb_z_diag_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
character, intent(in), optional :: upd
|
||||||
|
Integer :: err_act, nrow,i
|
||||||
|
character(len=20) :: name='z_diag_precbld'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
nrow = psb_cd_get_local_cols(desc_a)
|
||||||
|
if (allocated(prec%d)) then
|
||||||
|
if (size(prec%d) < nrow) then
|
||||||
|
deallocate(prec%d,stat=info)
|
||||||
|
end if
|
||||||
|
end if
|
||||||
|
if ((info == 0).and.(.not.allocated(prec%d))) then
|
||||||
|
allocate(prec%d(nrow), stat=info)
|
||||||
|
end if
|
||||||
|
if (info /= 0) then
|
||||||
|
info = 4000
|
||||||
|
call psb_errpush(info,name)
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
call a%get_diag(prec%d,info)
|
||||||
|
if (info /= 0) then
|
||||||
|
info = 4010
|
||||||
|
call psb_errpush(info,name, a_err='get_diag')
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
do i=1,nrow
|
||||||
|
if (prec%d(i) == dzero) then
|
||||||
|
prec%d(i) = done
|
||||||
|
else
|
||||||
|
prec%d(i) = done/prec%d(i)
|
||||||
|
endif
|
||||||
|
end do
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine z_diag_precbld
|
||||||
|
|
||||||
|
subroutine z_diag_precseti(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_diag_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
integer, intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='z_diag_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine z_diag_precseti
|
||||||
|
|
||||||
|
subroutine z_diag_precsetr(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_diag_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
real(psb_dpk_), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='z_diag_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine z_diag_precsetr
|
||||||
|
|
||||||
|
subroutine z_diag_precsetc(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_diag_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
character(len=*), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='z_diag_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine z_diag_precsetc
|
||||||
|
|
||||||
|
subroutine z_diag_precfree(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_diag_prec_type), intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='z_diag_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
|
||||||
|
end subroutine z_diag_precfree
|
||||||
|
|
||||||
|
|
||||||
|
subroutine z_diag_precdescr(prec,iout)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_diag_prec_type), intent(in) :: prec
|
||||||
|
integer, intent(in), optional :: iout
|
||||||
|
|
||||||
|
Integer :: err_act, nrow, info
|
||||||
|
character(len=20) :: name='z_diag_precdescr'
|
||||||
|
|
||||||
|
integer :: iout_
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
if (present(iout)) then
|
||||||
|
iout_ = iout
|
||||||
|
else
|
||||||
|
iout_ = 6
|
||||||
|
end if
|
||||||
|
|
||||||
|
write(iout_,*) 'Diagonal scaling'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
|
||||||
|
end subroutine z_diag_precdescr
|
||||||
|
|
||||||
|
function z_diag_sizeof(prec) result(val)
|
||||||
|
use psb_base_mod
|
||||||
|
class(psb_z_diag_prec_type), intent(in) :: prec
|
||||||
|
integer(psb_long_int_k_) :: val
|
||||||
|
|
||||||
|
val = 0
|
||||||
|
val = val + 2*psb_sizeof_dp * size(prec%d)
|
||||||
|
return
|
||||||
|
end function z_diag_sizeof
|
||||||
|
|
||||||
|
end module psb_z_diagprec
|
||||||
@ -0,0 +1,293 @@
|
|||||||
|
module psb_z_nullprec
|
||||||
|
use psb_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
type, extends(psb_z_base_prec_type) :: psb_z_null_prec_type
|
||||||
|
contains
|
||||||
|
procedure, pass(prec) :: apply => z_null_apply
|
||||||
|
procedure, pass(prec) :: precbld => z_null_precbld
|
||||||
|
procedure, pass(prec) :: precinit => z_null_precinit
|
||||||
|
procedure, pass(prec) :: z_base_precseti => z_null_precseti
|
||||||
|
procedure, pass(prec) :: z_base_precsetr => z_null_precsetr
|
||||||
|
procedure, pass(prec) :: z_base_precsetc => z_null_precsetc
|
||||||
|
procedure, pass(prec) :: precfree => z_null_precfree
|
||||||
|
procedure, pass(prec) :: precdescr => z_null_precdescr
|
||||||
|
procedure, pass(prec) :: sizeof => z_null_sizeof
|
||||||
|
end type psb_z_null_prec_type
|
||||||
|
|
||||||
|
|
||||||
|
contains
|
||||||
|
|
||||||
|
|
||||||
|
subroutine z_null_apply(alpha,prec,x,beta,y,desc_data,info,trans,work)
|
||||||
|
use psb_base_mod
|
||||||
|
type(psb_desc_type),intent(in) :: desc_data
|
||||||
|
class(psb_z_null_prec_type), intent(in) :: prec
|
||||||
|
complex(psb_dpk_),intent(in) :: x(:)
|
||||||
|
complex(psb_dpk_),intent(in) :: alpha, beta
|
||||||
|
complex(psb_dpk_),intent(inout) :: y(:)
|
||||||
|
integer, intent(out) :: info
|
||||||
|
character(len=1), optional :: trans
|
||||||
|
complex(psb_dpk_),intent(inout), optional, target :: work(:)
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='z_null_prec_apply'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
!
|
||||||
|
! This is the base version and we should throw an error.
|
||||||
|
! Or should it be the NULL preonditioner???
|
||||||
|
!
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
nrow = psb_cd_get_local_rows(desc_data)
|
||||||
|
if (size(x) < nrow) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/2,nrow,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
if (size(y) < nrow) then
|
||||||
|
info = 36
|
||||||
|
call psb_errpush(info,name,i_err=(/3,nrow,0,0,0/))
|
||||||
|
goto 9999
|
||||||
|
end if
|
||||||
|
|
||||||
|
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
||||||
|
if (info /= 0 ) then
|
||||||
|
info = 4010
|
||||||
|
call psb_errpush(infoi,name,a_err="psb_geaxpby")
|
||||||
|
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 z_null_apply
|
||||||
|
|
||||||
|
|
||||||
|
subroutine z_null_precinit(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_null_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='z_null_precinit'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine z_null_precinit
|
||||||
|
|
||||||
|
subroutine z_null_precbld(a,desc_a,prec,info,upd)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
type(psb_z_sparse_mat), intent(in), target :: a
|
||||||
|
type(psb_desc_type), intent(in), target :: desc_a
|
||||||
|
class(psb_z_null_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
character, intent(in), optional :: upd
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='z_null_precbld'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine z_null_precbld
|
||||||
|
|
||||||
|
subroutine z_null_precseti(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_null_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
integer, intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='z_null_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine z_null_precseti
|
||||||
|
|
||||||
|
subroutine z_null_precsetr(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_null_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
real(psb_dpk_), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='z_null_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine z_null_precsetr
|
||||||
|
|
||||||
|
subroutine z_null_precsetc(prec,what,val,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_null_prec_type),intent(inout) :: prec
|
||||||
|
integer, intent(in) :: what
|
||||||
|
character(len=*), intent(in) :: val
|
||||||
|
integer, intent(out) :: info
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='z_null_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
end subroutine z_null_precsetc
|
||||||
|
|
||||||
|
subroutine z_null_precfree(prec,info)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_null_prec_type), intent(inout) :: prec
|
||||||
|
integer, intent(out) :: info
|
||||||
|
|
||||||
|
Integer :: err_act, nrow
|
||||||
|
character(len=20) :: name='z_null_precset'
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
|
||||||
|
end subroutine z_null_precfree
|
||||||
|
|
||||||
|
|
||||||
|
subroutine z_null_precdescr(prec,iout)
|
||||||
|
|
||||||
|
use psb_base_mod
|
||||||
|
Implicit None
|
||||||
|
|
||||||
|
class(psb_z_null_prec_type), intent(in) :: prec
|
||||||
|
integer, intent(in), optional :: iout
|
||||||
|
|
||||||
|
Integer :: err_act, nrow, info
|
||||||
|
character(len=20) :: name='z_null_precset'
|
||||||
|
integer :: iout_
|
||||||
|
|
||||||
|
call psb_erractionsave(err_act)
|
||||||
|
|
||||||
|
info = 0
|
||||||
|
|
||||||
|
if (present(iout)) then
|
||||||
|
iout_ = iout
|
||||||
|
else
|
||||||
|
iout_ = 6
|
||||||
|
end if
|
||||||
|
|
||||||
|
write(iout_,*) 'No preconditioning'
|
||||||
|
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
return
|
||||||
|
|
||||||
|
9999 continue
|
||||||
|
call psb_erractionrestore(err_act)
|
||||||
|
if (err_act == psb_act_abort_) then
|
||||||
|
call psb_error()
|
||||||
|
return
|
||||||
|
end if
|
||||||
|
return
|
||||||
|
|
||||||
|
end subroutine z_null_precdescr
|
||||||
|
|
||||||
|
function z_null_sizeof(prec) result(val)
|
||||||
|
use psb_base_mod
|
||||||
|
class(psb_z_null_prec_type), intent(in) :: prec
|
||||||
|
integer(psb_long_int_k_) :: val
|
||||||
|
|
||||||
|
val = 0
|
||||||
|
|
||||||
|
return
|
||||||
|
end function z_null_sizeof
|
||||||
|
|
||||||
|
end module psb_z_nullprec
|
||||||
@ -1,166 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS version 2.2
|
|
||||||
!!$ (C) Copyright 2006/2007/2008
|
|
||||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ 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 PSBLAS 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 PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
subroutine psb_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
|
|
||||||
!
|
|
||||||
! Compute Y <- beta*Y + alpha*K^-1 X
|
|
||||||
! where K is a a Block Jacobi preconditioner stored in prec
|
|
||||||
! Note that desc_data may or may not be the same as prec%desc_data,
|
|
||||||
! but since both are INTENT(IN) this should be legal.
|
|
||||||
!
|
|
||||||
|
|
||||||
use psb_base_mod
|
|
||||||
use psb_prec_mod, psb_protect_name => psb_zbjac_aply
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
type(psb_desc_type), intent(in) :: desc_data
|
|
||||||
type(psb_zprec_type), intent(in) :: prec
|
|
||||||
complex(psb_dpk_),intent(in) :: x(:)
|
|
||||||
complex(psb_dpk_),intent(inout) :: y(:)
|
|
||||||
complex(psb_dpk_),intent(in) :: alpha,beta
|
|
||||||
character(len=1) :: trans
|
|
||||||
complex(psb_dpk_),target :: work(:)
|
|
||||||
integer, intent(out) :: info
|
|
||||||
|
|
||||||
! Local variables
|
|
||||||
integer :: n_row,n_col
|
|
||||||
complex(psb_dpk_), pointer :: ww(:), aux(:)
|
|
||||||
integer :: ictxt,np,me, err_act, int_err(5)
|
|
||||||
integer :: debug_level, debug_unit
|
|
||||||
character :: trans_
|
|
||||||
character(len=20) :: name, ch_err
|
|
||||||
|
|
||||||
name='psb_bjac_aply'
|
|
||||||
info = 0
|
|
||||||
call psb_erractionsave(err_act)
|
|
||||||
debug_unit = psb_get_debug_unit()
|
|
||||||
debug_level = psb_get_debug_level()
|
|
||||||
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
|
|
||||||
call psb_errpush(40,name)
|
|
||||||
goto 9999
|
|
||||||
end select
|
|
||||||
|
|
||||||
|
|
||||||
n_row=desc_data%matrix_data(psb_n_row_)
|
|
||||||
n_col=desc_data%matrix_data(psb_n_col_)
|
|
||||||
|
|
||||||
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 /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Allocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
endif
|
|
||||||
else
|
|
||||||
allocate(ww(n_col),aux(4*n_col),stat=info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Allocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
endif
|
|
||||||
|
|
||||||
|
|
||||||
select case(prec%iprcparm(psb_f_type_))
|
|
||||||
case(psb_f_ilu_n_)
|
|
||||||
|
|
||||||
select case(trans_)
|
|
||||||
case('N')
|
|
||||||
|
|
||||||
call psb_spsm(zone,prec%av(psb_l_pr_),x,zzero,ww,desc_data,info,&
|
|
||||||
& trans=trans_,scale='L',diag=prec%d,choice=psb_none_,work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,&
|
|
||||||
& trans=trans_,scale='U',choice=psb_none_, work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
|
|
||||||
case('T')
|
|
||||||
call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,ww,desc_data,info,&
|
|
||||||
& trans=trans_,scale='L',diag=prec%d,choice=psb_none_, work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,&
|
|
||||||
& trans=trans_,scale='U',choice=psb_none_,work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
|
|
||||||
case('C')
|
|
||||||
call psb_spsm(zone,prec%av(psb_u_pr_),x,zzero,ww,desc_data,info,&
|
|
||||||
& trans=trans_,scale='L',diag=conjg(prec%d),choice=psb_none_, work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,&
|
|
||||||
& trans=trans_,scale='U',choice=psb_none_,work=aux)
|
|
||||||
if(info /=0) goto 9999
|
|
||||||
|
|
||||||
end select
|
|
||||||
|
|
||||||
|
|
||||||
case default
|
|
||||||
info = 4001
|
|
||||||
call psb_errpush(info,name,a_err='Invalid factorization')
|
|
||||||
goto 9999
|
|
||||||
end select
|
|
||||||
|
|
||||||
call psb_halo(y,desc_data,info,data=psb_comm_mov_)
|
|
||||||
|
|
||||||
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_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 psb_zbjac_aply
|
|
||||||
@ -1,181 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS version 2.2
|
|
||||||
!!$ (C) Copyright 2006/2007/2008
|
|
||||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ 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 PSBLAS 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 PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
subroutine psb_zbjac_bld(a,desc_a,p,upd,info)
|
|
||||||
use psb_base_mod
|
|
||||||
use psb_prec_mod, psb_protect_name => psb_zbjac_bld
|
|
||||||
implicit none
|
|
||||||
!
|
|
||||||
! .. Scalar Arguments ..
|
|
||||||
integer, intent(out) :: info
|
|
||||||
! .. array Arguments ..
|
|
||||||
type(psb_z_sparse_mat), intent(in), target :: a
|
|
||||||
type(psb_zprec_type), intent(inout) :: p
|
|
||||||
type(psb_desc_type), intent(in) :: desc_a
|
|
||||||
character, intent(in) :: upd
|
|
||||||
|
|
||||||
! .. Local Scalars ..
|
|
||||||
integer :: i, m
|
|
||||||
integer :: int_err(5)
|
|
||||||
character :: trans, unitd
|
|
||||||
type(psb_z_csr_sparse_mat), allocatable :: lf, uf
|
|
||||||
real(psb_dpk_) :: t1,t2,t3,t4,t5,t6, t7, t8
|
|
||||||
integer nztota, err_act, n_row, nrow_a,n_col, nhalo
|
|
||||||
integer :: ictxt,np,me
|
|
||||||
character(len=20) :: name, ch_err
|
|
||||||
|
|
||||||
|
|
||||||
if(psb_get_errstatus() /= 0) return
|
|
||||||
info=0
|
|
||||||
name='psb_zbjac_bld'
|
|
||||||
call psb_erractionsave(err_act)
|
|
||||||
|
|
||||||
ictxt=psb_cd_get_context(desc_a)
|
|
||||||
call psb_info(ictxt, me, np)
|
|
||||||
|
|
||||||
m = a%get_nrows()
|
|
||||||
if (m < 0) then
|
|
||||||
info = 10
|
|
||||||
int_err(1) = 1
|
|
||||||
int_err(2) = m
|
|
||||||
call psb_errpush(info,name,i_err=int_err)
|
|
||||||
goto 9999
|
|
||||||
endif
|
|
||||||
trans = 'N'
|
|
||||||
unitd = 'U'
|
|
||||||
|
|
||||||
call psb_cdcpy(desc_a,p%desc_data,info)
|
|
||||||
if(info /= 0) then
|
|
||||||
info=4010
|
|
||||||
ch_err='psb_cdcpy'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
|
|
||||||
select case(p%iprcparm(psb_f_type_))
|
|
||||||
|
|
||||||
case(psb_f_ilu_n_)
|
|
||||||
|
|
||||||
if (allocated(p%av)) then
|
|
||||||
if (size(p%av) < psb_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(psb_max_avsz),stat=info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4000,name)
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
endif
|
|
||||||
|
|
||||||
nrow_a = psb_cd_get_local_rows(desc_a)
|
|
||||||
nztota = a%get_nzeros()
|
|
||||||
|
|
||||||
n_col = psb_cd_get_local_cols(desc_a)
|
|
||||||
nhalo = n_col-nrow_a
|
|
||||||
n_row = p%desc_data%matrix_data(psb_n_row_)
|
|
||||||
|
|
||||||
allocate(lf,uf,stat=info)
|
|
||||||
if (info == 0) call lf%allocate(n_row,n_row,nztota)
|
|
||||||
if (info == 0) call uf%allocate(n_row,n_row,nztota)
|
|
||||||
|
|
||||||
if(info/=0) then
|
|
||||||
info=4010
|
|
||||||
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 /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Allocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
endif
|
|
||||||
t3 = psb_wtime()
|
|
||||||
! This is where we have no renumbering, thus no need
|
|
||||||
call psb_ilu_fct(a,lf,uf,p%d,info)
|
|
||||||
|
|
||||||
if(info==0) then
|
|
||||||
call p%av(psb_l_pr_)%mv_from(lf)
|
|
||||||
call p%av(psb_u_pr_)%mv_from(uf)
|
|
||||||
call p%av(psb_l_pr_)%set_asb()
|
|
||||||
call p%av(psb_u_pr_)%set_asb()
|
|
||||||
call p%av(psb_l_pr_)%trim()
|
|
||||||
call p%av(psb_u_pr_)%trim()
|
|
||||||
else
|
|
||||||
info=4010
|
|
||||||
ch_err='psb_ilu_fct'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
case(psb_f_none_)
|
|
||||||
info=4010
|
|
||||||
ch_err='Inconsistent prec psb_f_none_'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
goto 9999
|
|
||||||
|
|
||||||
case default
|
|
||||||
info=4010
|
|
||||||
ch_err='Unknown psb_f_type_'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
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 psb_zbjac_bld
|
|
||||||
|
|
||||||
|
|
||||||
@ -1,120 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS version 2.2
|
|
||||||
!!$ (C) Copyright 2006/2007/2008
|
|
||||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ 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 PSBLAS 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 PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info)
|
|
||||||
|
|
||||||
use psb_base_mod
|
|
||||||
use psb_prec_mod, psb_protect_name => psb_zdiagsc_bld
|
|
||||||
Implicit None
|
|
||||||
|
|
||||||
type(psb_z_sparse_mat), intent(in), target :: a
|
|
||||||
type(psb_desc_type), intent(in) :: desc_a
|
|
||||||
type(psb_zprec_type),intent(inout) :: p
|
|
||||||
character, intent(in) :: upd
|
|
||||||
integer, intent(out) :: info
|
|
||||||
|
|
||||||
|
|
||||||
! Local scalars
|
|
||||||
Integer :: err, n_row, n_col,I,ictxt,&
|
|
||||||
& me,np,mglob,err_act
|
|
||||||
integer :: int_err(5)
|
|
||||||
|
|
||||||
integer,parameter :: iroot=psb_root_,iout=60,ilout=40
|
|
||||||
character(len=20) :: name, ch_err
|
|
||||||
|
|
||||||
if(psb_get_errstatus() /= 0) return
|
|
||||||
info=0
|
|
||||||
err=0
|
|
||||||
call psb_erractionsave(err_act)
|
|
||||||
name = 'psb_diagsc_bld'
|
|
||||||
|
|
||||||
info = 0
|
|
||||||
int_err(1) = 0
|
|
||||||
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)
|
|
||||||
|
|
||||||
! diagonal scaling
|
|
||||||
|
|
||||||
call psb_realloc(n_col,p%d,info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='psb_realloc')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
!
|
|
||||||
! Retrieve the diagonal entries of the matrix A
|
|
||||||
!
|
|
||||||
call a%get_diag(p%d,info)
|
|
||||||
if(info /= 0) then
|
|
||||||
info=4010
|
|
||||||
ch_err='psb_sp_getdiag'
|
|
||||||
call psb_errpush(info,name,a_err=ch_err)
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
!
|
|
||||||
! Copy into p%desc_data the descriptor associated to A
|
|
||||||
!
|
|
||||||
call psb_cdcpy(desc_a,p%desc_Data,info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='psb_cdcpy')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
!
|
|
||||||
! The i-th diagonal entry of the preconditioner is set to one if the
|
|
||||||
! corresponding entry a_ii of the sparse matrix A is zero; otherwise
|
|
||||||
! it is set to one/a_ii
|
|
||||||
!
|
|
||||||
do i=1,n_row
|
|
||||||
if (p%d(i) == zzero) then
|
|
||||||
p%d(i) = zone
|
|
||||||
else
|
|
||||||
p%d(i) = zone/p%d(i)
|
|
||||||
endif
|
|
||||||
end do
|
|
||||||
|
|
||||||
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 psb_zdiagsc_bld
|
|
||||||
|
|
||||||
@ -1,140 +0,0 @@
|
|||||||
!!$
|
|
||||||
!!$ Parallel Sparse BLAS version 2.2
|
|
||||||
!!$ (C) Copyright 2006/2007/2008
|
|
||||||
!!$ Salvatore Filippone University of Rome Tor Vergata
|
|
||||||
!!$ Alfredo Buttari University of Rome Tor Vergata
|
|
||||||
!!$
|
|
||||||
!!$ 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 PSBLAS 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 PSBLAS GROUP OR ITS CONTRIBUTORS
|
|
||||||
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
|
||||||
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
|
||||||
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
||||||
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
|
||||||
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
|
||||||
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
|
||||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
|
||||||
!!$
|
|
||||||
!!$
|
|
||||||
subroutine psb_zgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
|
|
||||||
!
|
|
||||||
! Compute Y <- beta*Y + alpha*K^-1 X
|
|
||||||
! where K is a a basic preconditioner stored in prec
|
|
||||||
!
|
|
||||||
|
|
||||||
use psb_base_mod
|
|
||||||
use psb_prec_mod, psb_protect_name => psb_zgprec_aply
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
type(psb_desc_type),intent(in) :: desc_data
|
|
||||||
type(psb_zprec_type), intent(in) :: prec
|
|
||||||
complex(psb_dpk_),intent(in) :: x(:)
|
|
||||||
complex(psb_dpk_),intent(inout) :: y(:)
|
|
||||||
complex(psb_dpk_),intent(in) :: alpha,beta
|
|
||||||
character(len=1) :: trans
|
|
||||||
complex(psb_dpk_),target :: work(:)
|
|
||||||
integer, intent(out) :: info
|
|
||||||
|
|
||||||
! Local variables
|
|
||||||
integer :: n_row,int_err(5)
|
|
||||||
complex(psb_dpk_), pointer :: ww(:)
|
|
||||||
character :: trans_
|
|
||||||
integer :: ictxt,np,me, err_act
|
|
||||||
character(len=20) :: name, ch_err
|
|
||||||
|
|
||||||
|
|
||||||
name='psb_zgprec_aply'
|
|
||||||
info = 0
|
|
||||||
call psb_erractionsave(err_act)
|
|
||||||
|
|
||||||
ictxt=desc_data%matrix_data(psb_ctxt_)
|
|
||||||
call psb_info(ictxt, me, np)
|
|
||||||
|
|
||||||
trans_ = psb_toupper(trans)
|
|
||||||
|
|
||||||
select case(trans_)
|
|
||||||
case('N')
|
|
||||||
case('T','C')
|
|
||||||
case default
|
|
||||||
info=40
|
|
||||||
int_err(1)=6
|
|
||||||
ch_err(2:2)=trans
|
|
||||||
goto 9999
|
|
||||||
end select
|
|
||||||
|
|
||||||
select case(prec%iprcparm(psb_p_type_))
|
|
||||||
|
|
||||||
case(psb_noprec_)
|
|
||||||
|
|
||||||
call psb_geaxpby(alpha,x,beta,y,desc_data,info)
|
|
||||||
|
|
||||||
case(psb_diag_)
|
|
||||||
|
|
||||||
if (size(work) >= size(x)) then
|
|
||||||
ww => work
|
|
||||||
else
|
|
||||||
allocate(ww(size(x)),stat=info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Allocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
end if
|
|
||||||
|
|
||||||
n_row=desc_data%matrix_data(psb_n_row_)
|
|
||||||
if (trans_=='C') then
|
|
||||||
ww(1:n_row) = x(1:n_row)*conjg(prec%d(1:n_row))
|
|
||||||
else
|
|
||||||
ww(1:n_row) = x(1:n_row)*prec%d(1:n_row)
|
|
||||||
endif
|
|
||||||
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
|
|
||||||
|
|
||||||
if (size(work) < size(x)) then
|
|
||||||
deallocate(ww,stat=info)
|
|
||||||
if (info /= 0) then
|
|
||||||
call psb_errpush(4010,name,a_err='Deallocate')
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
end if
|
|
||||||
|
|
||||||
case(psb_bjac_)
|
|
||||||
|
|
||||||
call psb_bjac_aply(alpha,prec,x,beta,y,desc_data,trans_,work,info)
|
|
||||||
if(info /= 0) then
|
|
||||||
info=4010
|
|
||||||
ch_err='psb_bjac_aply'
|
|
||||||
goto 9999
|
|
||||||
end if
|
|
||||||
|
|
||||||
case default
|
|
||||||
info = 4001
|
|
||||||
call psb_errpush(info,name,a_err='Invalid prectype')
|
|
||||||
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 psb_zgprec_aply
|
|
||||||
|
|
||||||
@ -1,13 +1,13 @@
|
|||||||
11 Number of inputs
|
11 Number of inputs
|
||||||
thm200x120.mtx sherman3.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or
|
10974x10974.mtx sherman3.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or
|
||||||
NONE sherman3_rhs1.mtx http://www.cise.ufl.edu/research/sparse/matrices/index.html
|
NONE sherman3_rhs1.mtx http://www.cise.ufl.edu/research/sparse/matrices/index.html
|
||||||
MM File format: MM: Matrix Market HB: Harwell-Boeing.
|
MM File format: MM: Matrix Market HB: Harwell-Boeing.
|
||||||
BICGSTAB Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL BICG CG
|
BICGSTAB Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL BICG CG
|
||||||
BJAC Preconditioner NONE DIAG BJAC
|
BJAC Preconditioner NONE DIAG BJAC
|
||||||
CSR Storage format CSR COO JAD
|
CSR Storage format CSR COO JAD
|
||||||
2 IPART: Partition method 0: BLK 2: graph (with Metis)
|
0 IPART: Partition method 0: BLK 2: graph (with Metis)
|
||||||
2 ISTOPC
|
2 ISTOPC
|
||||||
01000 ITMAX
|
00010 ITMAX
|
||||||
01 ITRACE
|
01 ITRACE
|
||||||
30 IRST (restart for RGMRES and BiCGSTABL)
|
30 IRST (restart for RGMRES and BiCGSTABL)
|
||||||
1.d-6 EPS
|
1.d-6 EPS
|
||||||
|
|||||||
Loading…
Reference in New Issue