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

Added implementation in BJAC and test for ILU-type factorizations

Browse Source
implement-ainv
Cirdans-Home 4 years ago
parent f0bb949192
commit fbf23c3959
20 changed files with 2230 additions and 818 deletions
Show Stats Download Patch File Download Diff File

14
base/modules/serial/psb_c_mat_mod.F90
Unescape Escape View File

@ -128,6 +128,7 @@ module psb_c_mat_mod
! Memory/data management
procedure, pass(a) :: csall => psb_c_csall
generic, public :: allocate => csall
procedure, pass(a) :: free => psb_c_free
procedure, pass(a) :: trim => psb_c_trim
procedure, pass(a) :: csput_a => psb_c_csput_a
@ -326,6 +327,7 @@ module psb_c_mat_mod
! Memory/data management
procedure, pass(a) :: csall => psb_lc_csall
generic, public :: allocate => csall
procedure, pass(a) :: free => psb_lc_free
procedure, pass(a) :: trim => psb_lc_trim
procedure, pass(a) :: csput_a => psb_lc_csput_a
@ -604,12 +606,14 @@ module psb_c_mat_mod
end interface
interface
subroutine psb_c_csall(nr,nc,a,info,nz)
import :: psb_ipk_, psb_lpk_, psb_cspmat_type
subroutine psb_c_csall(nr,nc,a,info,nz,type,mold)
import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_c_base_sparse_mat
class(psb_cspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: nr,nc
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psb_c_base_sparse_mat), optional, intent(in) :: mold
end subroutine psb_c_csall
end interface
@ -1384,12 +1388,14 @@ module psb_c_mat_mod
end interface
interface
subroutine psb_lc_csall(nr,nc,a,info,nz)
import :: psb_ipk_, psb_lpk_, psb_lcspmat_type
subroutine psb_lc_csall(nr,nc,a,info,nz,type,mold)
import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_lc_base_sparse_mat
class(psb_lcspmat_type), intent(inout) :: a
integer(psb_lpk_), intent(in) :: nr,nc
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psb_lc_base_sparse_mat), optional, intent(in) :: mold
end subroutine psb_lc_csall
end interface

14
base/modules/serial/psb_d_mat_mod.F90
Unescape Escape View File

@ -128,6 +128,7 @@ module psb_d_mat_mod
! Memory/data management
procedure, pass(a) :: csall => psb_d_csall
generic, public :: allocate => csall
procedure, pass(a) :: free => psb_d_free
procedure, pass(a) :: trim => psb_d_trim
procedure, pass(a) :: csput_a => psb_d_csput_a
@ -326,6 +327,7 @@ module psb_d_mat_mod
! Memory/data management
procedure, pass(a) :: csall => psb_ld_csall
generic, public :: allocate => csall
procedure, pass(a) :: free => psb_ld_free
procedure, pass(a) :: trim => psb_ld_trim
procedure, pass(a) :: csput_a => psb_ld_csput_a
@ -604,12 +606,14 @@ module psb_d_mat_mod
end interface
interface
subroutine psb_d_csall(nr,nc,a,info,nz)
import :: psb_ipk_, psb_lpk_, psb_dspmat_type
subroutine psb_d_csall(nr,nc,a,info,nz,type,mold)
import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_d_base_sparse_mat
class(psb_dspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: nr,nc
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psb_d_base_sparse_mat), optional, intent(in) :: mold
end subroutine psb_d_csall
end interface
@ -1384,12 +1388,14 @@ module psb_d_mat_mod
end interface
interface
subroutine psb_ld_csall(nr,nc,a,info,nz)
import :: psb_ipk_, psb_lpk_, psb_ldspmat_type
subroutine psb_ld_csall(nr,nc,a,info,nz,type,mold)
import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_ld_base_sparse_mat
class(psb_ldspmat_type), intent(inout) :: a
integer(psb_lpk_), intent(in) :: nr,nc
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psb_ld_base_sparse_mat), optional, intent(in) :: mold
end subroutine psb_ld_csall
end interface

14
base/modules/serial/psb_s_mat_mod.F90
Unescape Escape View File

@ -128,6 +128,7 @@ module psb_s_mat_mod
! Memory/data management
procedure, pass(a) :: csall => psb_s_csall
generic, public :: allocate => csall
procedure, pass(a) :: free => psb_s_free
procedure, pass(a) :: trim => psb_s_trim
procedure, pass(a) :: csput_a => psb_s_csput_a
@ -326,6 +327,7 @@ module psb_s_mat_mod
! Memory/data management
procedure, pass(a) :: csall => psb_ls_csall
generic, public :: allocate => csall
procedure, pass(a) :: free => psb_ls_free
procedure, pass(a) :: trim => psb_ls_trim
procedure, pass(a) :: csput_a => psb_ls_csput_a
@ -604,12 +606,14 @@ module psb_s_mat_mod
end interface
interface
subroutine psb_s_csall(nr,nc,a,info,nz)
import :: psb_ipk_, psb_lpk_, psb_sspmat_type
subroutine psb_s_csall(nr,nc,a,info,nz,type,mold)
import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_s_base_sparse_mat
class(psb_sspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: nr,nc
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psb_s_base_sparse_mat), optional, intent(in) :: mold
end subroutine psb_s_csall
end interface
@ -1384,12 +1388,14 @@ module psb_s_mat_mod
end interface
interface
subroutine psb_ls_csall(nr,nc,a,info,nz)
import :: psb_ipk_, psb_lpk_, psb_lsspmat_type
subroutine psb_ls_csall(nr,nc,a,info,nz,type,mold)
import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_ls_base_sparse_mat
class(psb_lsspmat_type), intent(inout) :: a
integer(psb_lpk_), intent(in) :: nr,nc
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psb_ls_base_sparse_mat), optional, intent(in) :: mold
end subroutine psb_ls_csall
end interface

14
base/modules/serial/psb_z_mat_mod.F90
Unescape Escape View File

@ -128,6 +128,7 @@ module psb_z_mat_mod
! Memory/data management
procedure, pass(a) :: csall => psb_z_csall
generic, public :: allocate => csall
procedure, pass(a) :: free => psb_z_free
procedure, pass(a) :: trim => psb_z_trim
procedure, pass(a) :: csput_a => psb_z_csput_a
@ -326,6 +327,7 @@ module psb_z_mat_mod
! Memory/data management
procedure, pass(a) :: csall => psb_lz_csall
generic, public :: allocate => csall
procedure, pass(a) :: free => psb_lz_free
procedure, pass(a) :: trim => psb_lz_trim
procedure, pass(a) :: csput_a => psb_lz_csput_a
@ -604,12 +606,14 @@ module psb_z_mat_mod
end interface
interface
subroutine psb_z_csall(nr,nc,a,info,nz)
import :: psb_ipk_, psb_lpk_, psb_zspmat_type
subroutine psb_z_csall(nr,nc,a,info,nz,type,mold)
import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_z_base_sparse_mat
class(psb_zspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: nr,nc
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psb_z_base_sparse_mat), optional, intent(in) :: mold
end subroutine psb_z_csall
end interface
@ -1384,12 +1388,14 @@ module psb_z_mat_mod
end interface
interface
subroutine psb_lz_csall(nr,nc,a,info,nz)
import :: psb_ipk_, psb_lpk_, psb_lzspmat_type
subroutine psb_lz_csall(nr,nc,a,info,nz,type,mold)
import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_lz_base_sparse_mat
class(psb_lzspmat_type), intent(inout) :: a
integer(psb_lpk_), intent(in) :: nr,nc
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psb_lz_base_sparse_mat), optional, intent(in) :: mold
end subroutine psb_lz_csall
end interface

39
base/serial/impl/psb_c_mat_impl.F90
Unescape Escape View File

@ -582,7 +582,7 @@ end subroutine psb_c_get_neigh
subroutine psb_c_csall(nr,nc,a,info,nz)
subroutine psb_c_csall(nr,nc,a,info,nz,type,mold)
use psb_c_mat_mod, psb_protect_name => psb_c_csall
use psb_c_base_mat_mod
use psb_error_mod
@ -591,6 +591,8 @@ subroutine psb_c_csall(nr,nc,a,info,nz)
integer(psb_ipk_), intent(in) :: nr,nc
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psb_c_base_sparse_mat), optional, intent(in) :: mold
integer(psb_ipk_) :: err_act
character(len=20) :: name='csall'
@ -601,7 +603,23 @@ subroutine psb_c_csall(nr,nc,a,info,nz)
call a%free()
info = psb_success_
if (present(mold)) then
allocate(a%a, stat=info, mold=mold)
else if (present(type)) then
select case (type)
case('CSR')
allocate(psb_c_csr_sparse_mat :: a%a, stat=info)
case('COO')
allocate(psb_c_coo_sparse_mat :: a%a, stat=info)
case('CSC')
allocate(psb_c_csc_sparse_mat :: a%a, stat=info)
case default
allocate(psb_c_coo_sparse_mat :: a%a, stat=info)
end select
else
allocate(psb_c_coo_sparse_mat :: a%a, stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name)
@ -3381,7 +3399,7 @@ end subroutine psb_lc_get_neigh
subroutine psb_lc_csall(nr,nc,a,info,nz)
subroutine psb_lc_csall(nr,nc,a,info,nz,type,mold)
use psb_c_mat_mod, psb_protect_name => psb_lc_csall
use psb_c_base_mat_mod
use psb_error_mod
@ -3390,6 +3408,8 @@ subroutine psb_lc_csall(nr,nc,a,info,nz)
integer(psb_lpk_), intent(in) :: nr,nc
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psb_lc_base_sparse_mat), optional, intent(in) :: mold
integer(psb_ipk_) :: err_act
character(len=20) :: name='csall'
@ -3400,7 +3420,22 @@ subroutine psb_lc_csall(nr,nc,a,info,nz)
call a%free()
info = psb_success_
if (present(mold)) then
allocate(a%a, stat=info, mold=mold)
else if (present(type)) then
select case (type)
case('CSR')
allocate(psb_lc_csr_sparse_mat :: a%a, stat=info)
case('COO')
allocate(psb_lc_coo_sparse_mat :: a%a, stat=info)
case('CSC')
allocate(psb_lc_csc_sparse_mat :: a%a, stat=info)
case default
allocate(psb_lc_coo_sparse_mat :: a%a, stat=info)
end select
else
allocate(psb_lc_coo_sparse_mat :: a%a, stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name)

39
base/serial/impl/psb_d_mat_impl.F90
Unescape Escape View File

@ -582,7 +582,7 @@ end subroutine psb_d_get_neigh
subroutine psb_d_csall(nr,nc,a,info,nz)
subroutine psb_d_csall(nr,nc,a,info,nz,type,mold)
use psb_d_mat_mod, psb_protect_name => psb_d_csall
use psb_d_base_mat_mod
use psb_error_mod
@ -591,6 +591,8 @@ subroutine psb_d_csall(nr,nc,a,info,nz)
integer(psb_ipk_), intent(in) :: nr,nc
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psb_d_base_sparse_mat), optional, intent(in) :: mold
integer(psb_ipk_) :: err_act
character(len=20) :: name='csall'
@ -601,7 +603,23 @@ subroutine psb_d_csall(nr,nc,a,info,nz)
call a%free()
info = psb_success_
if (present(mold)) then
allocate(a%a, stat=info, mold=mold)
else if (present(type)) then
select case (type)
case('CSR')
allocate(psb_d_csr_sparse_mat :: a%a, stat=info)
case('COO')
allocate(psb_d_coo_sparse_mat :: a%a, stat=info)
case('CSC')
allocate(psb_d_csc_sparse_mat :: a%a, stat=info)
case default
allocate(psb_d_coo_sparse_mat :: a%a, stat=info)
end select
else
allocate(psb_d_coo_sparse_mat :: a%a, stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name)
@ -3381,7 +3399,7 @@ end subroutine psb_ld_get_neigh
subroutine psb_ld_csall(nr,nc,a,info,nz)
subroutine psb_ld_csall(nr,nc,a,info,nz,type,mold)
use psb_d_mat_mod, psb_protect_name => psb_ld_csall
use psb_d_base_mat_mod
use psb_error_mod
@ -3390,6 +3408,8 @@ subroutine psb_ld_csall(nr,nc,a,info,nz)
integer(psb_lpk_), intent(in) :: nr,nc
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psb_ld_base_sparse_mat), optional, intent(in) :: mold
integer(psb_ipk_) :: err_act
character(len=20) :: name='csall'
@ -3400,7 +3420,22 @@ subroutine psb_ld_csall(nr,nc,a,info,nz)
call a%free()
info = psb_success_
if (present(mold)) then
allocate(a%a, stat=info, mold=mold)
else if (present(type)) then
select case (type)
case('CSR')
allocate(psb_ld_csr_sparse_mat :: a%a, stat=info)
case('COO')
allocate(psb_ld_coo_sparse_mat :: a%a, stat=info)
case('CSC')
allocate(psb_ld_csc_sparse_mat :: a%a, stat=info)
case default
allocate(psb_ld_coo_sparse_mat :: a%a, stat=info)
end select
else
allocate(psb_ld_coo_sparse_mat :: a%a, stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name)

39
base/serial/impl/psb_s_mat_impl.F90
Unescape Escape View File

@ -582,7 +582,7 @@ end subroutine psb_s_get_neigh
subroutine psb_s_csall(nr,nc,a,info,nz)
subroutine psb_s_csall(nr,nc,a,info,nz,type,mold)
use psb_s_mat_mod, psb_protect_name => psb_s_csall
use psb_s_base_mat_mod
use psb_error_mod
@ -591,6 +591,8 @@ subroutine psb_s_csall(nr,nc,a,info,nz)
integer(psb_ipk_), intent(in) :: nr,nc
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psb_s_base_sparse_mat), optional, intent(in) :: mold
integer(psb_ipk_) :: err_act
character(len=20) :: name='csall'
@ -601,7 +603,23 @@ subroutine psb_s_csall(nr,nc,a,info,nz)
call a%free()
info = psb_success_
if (present(mold)) then
allocate(a%a, stat=info, mold=mold)
else if (present(type)) then
select case (type)
case('CSR')
allocate(psb_s_csr_sparse_mat :: a%a, stat=info)
case('COO')
allocate(psb_s_coo_sparse_mat :: a%a, stat=info)
case('CSC')
allocate(psb_s_csc_sparse_mat :: a%a, stat=info)
case default
allocate(psb_s_coo_sparse_mat :: a%a, stat=info)
end select
else
allocate(psb_s_coo_sparse_mat :: a%a, stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name)
@ -3381,7 +3399,7 @@ end subroutine psb_ls_get_neigh
subroutine psb_ls_csall(nr,nc,a,info,nz)
subroutine psb_ls_csall(nr,nc,a,info,nz,type,mold)
use psb_s_mat_mod, psb_protect_name => psb_ls_csall
use psb_s_base_mat_mod
use psb_error_mod
@ -3390,6 +3408,8 @@ subroutine psb_ls_csall(nr,nc,a,info,nz)
integer(psb_lpk_), intent(in) :: nr,nc
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psb_ls_base_sparse_mat), optional, intent(in) :: mold
integer(psb_ipk_) :: err_act
character(len=20) :: name='csall'
@ -3400,7 +3420,22 @@ subroutine psb_ls_csall(nr,nc,a,info,nz)
call a%free()
info = psb_success_
if (present(mold)) then
allocate(a%a, stat=info, mold=mold)
else if (present(type)) then
select case (type)
case('CSR')
allocate(psb_ls_csr_sparse_mat :: a%a, stat=info)
case('COO')
allocate(psb_ls_coo_sparse_mat :: a%a, stat=info)
case('CSC')
allocate(psb_ls_csc_sparse_mat :: a%a, stat=info)
case default
allocate(psb_ls_coo_sparse_mat :: a%a, stat=info)
end select
else
allocate(psb_ls_coo_sparse_mat :: a%a, stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name)

39
base/serial/impl/psb_z_mat_impl.F90
Unescape Escape View File

@ -582,7 +582,7 @@ end subroutine psb_z_get_neigh
subroutine psb_z_csall(nr,nc,a,info,nz)
subroutine psb_z_csall(nr,nc,a,info,nz,type,mold)
use psb_z_mat_mod, psb_protect_name => psb_z_csall
use psb_z_base_mat_mod
use psb_error_mod
@ -591,6 +591,8 @@ subroutine psb_z_csall(nr,nc,a,info,nz)
integer(psb_ipk_), intent(in) :: nr,nc
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psb_z_base_sparse_mat), optional, intent(in) :: mold
integer(psb_ipk_) :: err_act
character(len=20) :: name='csall'
@ -601,7 +603,23 @@ subroutine psb_z_csall(nr,nc,a,info,nz)
call a%free()
info = psb_success_
if (present(mold)) then
allocate(a%a, stat=info, mold=mold)
else if (present(type)) then
select case (type)
case('CSR')
allocate(psb_z_csr_sparse_mat :: a%a, stat=info)
case('COO')
allocate(psb_z_coo_sparse_mat :: a%a, stat=info)
case('CSC')
allocate(psb_z_csc_sparse_mat :: a%a, stat=info)
case default
allocate(psb_z_coo_sparse_mat :: a%a, stat=info)
end select
else
allocate(psb_z_coo_sparse_mat :: a%a, stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name)
@ -3381,7 +3399,7 @@ end subroutine psb_lz_get_neigh
subroutine psb_lz_csall(nr,nc,a,info,nz)
subroutine psb_lz_csall(nr,nc,a,info,nz,type,mold)
use psb_z_mat_mod, psb_protect_name => psb_lz_csall
use psb_z_base_mat_mod
use psb_error_mod
@ -3390,6 +3408,8 @@ subroutine psb_lz_csall(nr,nc,a,info,nz)
integer(psb_lpk_), intent(in) :: nr,nc
integer(psb_ipk_), intent(out) :: info
integer(psb_lpk_), intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psb_lz_base_sparse_mat), optional, intent(in) :: mold
integer(psb_ipk_) :: err_act
character(len=20) :: name='csall'
@ -3400,7 +3420,22 @@ subroutine psb_lz_csall(nr,nc,a,info,nz)
call a%free()
info = psb_success_
if (present(mold)) then
allocate(a%a, stat=info, mold=mold)
else if (present(type)) then
select case (type)
case('CSR')
allocate(psb_lz_csr_sparse_mat :: a%a, stat=info)
case('COO')
allocate(psb_lz_coo_sparse_mat :: a%a, stat=info)
case('CSC')
allocate(psb_lz_csc_sparse_mat :: a%a, stat=info)
case default
allocate(psb_lz_coo_sparse_mat :: a%a, stat=info)
end select
else
allocate(psb_lz_coo_sparse_mat :: a%a, stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info, name)

295
prec/impl/psb_c_bjacprec_impl.f90
Unescape Escape View File

@ -161,7 +161,7 @@ subroutine psb_c_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work)
associate (wv => prec%wrk(1), wv1 => prec%wrk(2))
select case(prec%iprcparm(psb_f_type_))
case(psb_f_ilu_n_)
case(psb_f_ilu_n_,psb_f_ilu_k_,psb_f_ilu_t_)
select case(trans_)
case('N')
@ -314,7 +314,7 @@ subroutine psb_c_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work)
select case(prec%iprcparm(psb_f_type_))
case(psb_f_ilu_n_)
case(psb_f_ilu_n_,psb_f_ilu_k_,psb_f_ilu_t_)
select case(trans_)
case('N')
@ -389,6 +389,7 @@ subroutine psb_c_bjac_precinit(prec,info)
info = psb_success_
call psb_realloc(psb_ifpsz,prec%iprcparm,info)
call psb_realloc(psb_rfpsz,prec%rprcparm,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_Errpush(info,name)
@ -399,6 +400,11 @@ subroutine psb_c_bjac_precinit(prec,info)
prec%iprcparm(psb_p_type_) = psb_bjac_
prec%iprcparm(psb_f_type_) = psb_f_ilu_n_
prec%iprcparm(psb_ilu_fill_in_) = 0
prec%iprcparm(psb_ilu_ialg_) = psb_ilu_n_
prec%iprcparm(psb_ilu_scale_) = psb_ilu_scale_none_
prec%rprcparm(:) = 0
prec%rprcparm(psb_fact_eps_) = 1E-1_psb_spk_
call psb_erractionrestore(err_act)
@ -413,7 +419,7 @@ end subroutine psb_c_bjac_precinit
subroutine psb_c_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
use psb_base_mod
use psb_prec_mod, only : psb_ilu_fct
use psb_c_ilu_fact_mod
use psb_c_bjacprec, psb_protect_name => psb_c_bjac_precbld
Implicit None
@ -426,11 +432,12 @@ subroutine psb_c_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
class(psb_i_base_vect_type), intent(in), optional :: imold
! .. Local Scalars ..
integer(psb_ipk_) :: i, m
integer(psb_ipk_) :: i, m, ialg, fill_in, iscale
integer(psb_ipk_) :: ierr(5)
character :: trans, unitd
type(psb_c_csr_sparse_mat), allocatable :: lf, uf
type(psb_cspmat_type), allocatable :: lf, uf
complex(psb_spk_), allocatable :: dd(:)
real(psb_spk_) :: fact_eps
integer(psb_ipk_) :: nztota, err_act, n_row, nrow_a,n_col, nhalo
integer(psb_ipk_) :: ictxt,np,me
character(len=20) :: name='c_bjac_precbld'
@ -458,9 +465,204 @@ subroutine psb_c_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
trans = 'N'
unitd = 'U'
! We check if all the information contained in the preconditioner structure
! are meaningful, otherwise we give an error and get out of the build
! procedure
ialg = prec%iprcparm(psb_ilu_ialg_)
if ((ialg == psb_ilu_n_).or.(ialg == psb_milu_n_).or.(ialg == psb_ilu_t_)) then
! Do nothing: admissible request
else
info=psb_err_from_subroutine_
ch_err='psb_ilu_ialg_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iscale = prec%iprcparm(psb_ilu_scale_)
if ((iscale == psb_ilu_scale_none_).or.&
(iscale == psb_ilu_scale_maxval_).or.&
(iscale == psb_ilu_scale_diag_).or.&
(iscale == psb_ilu_scale_arwsum_).or.&
(iscale == psb_ilu_scale_aclsum_).or.&
(iscale == psb_ilu_scale_arcsum_)) then
! Do nothing: admissible request
else
info=psb_err_from_subroutine_
ch_err='psb_ilu_scale_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
fact_eps = prec%rprcparm(psb_fact_eps_)
if(fact_eps > 1 ) then
info=psb_err_from_subroutine_
ch_err='psb_fact_eps_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
fill_in = prec%iprcparm(psb_ilu_fill_in_)
if(fill_in < 0) then
info=psb_err_from_subroutine_
ch_err='psb_ilu_fill_in_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
else if (fill_in == 0) then
! If the requested level of fill is equal to zero, we default to the
! specialized ILU(0) routine
prec%iprcparm(psb_f_type_) = psb_f_ilu_n_
end if
! Select on the type of factorization to be used
select case(prec%iprcparm(psb_f_type_))
case(psb_f_ilu_n_)
! ILU(0) Factorization: the total number of nonzeros of the factorized matrix
! is equal to the one of the input matrix
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 /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
endif
nrow_a = desc_a%get_local_rows()
nztota = a%get_nzeros()
n_col = desc_a%get_local_cols()
nhalo = n_col-nrow_a
n_row = nrow_a
allocate(lf,uf,stat=info)
if (info == psb_success_) call lf%allocate(n_row,n_row,nztota)
if (info == psb_success_) call uf%allocate(n_row,n_row,nztota)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
allocate(dd(n_row),stat=info)
if (info == psb_success_) then
allocate(prec%dv, stat=info)
if (info == 0) then
if (present(vmold)) then
allocate(prec%dv%v,mold=vmold,stat=info)
else
allocate(psb_c_base_vect_type :: prec%dv%v,stat=info)
end if
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
endif
! This is where we have no renumbering, thus no need
! call psb_ilu_fct(a,lf,uf,dd,info)
call psb_ilu0_fact(ialg,a,lf,uf,dd,info)
if(info == psb_success_) then
call prec%av(psb_l_pr_)%mv_from(lf%a)
call prec%av(psb_u_pr_)%mv_from(uf%a)
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()
call prec%dv%bld(dd)
! call move_alloc(dd,prec%d)
else
info=psb_err_from_subroutine_
ch_err='psb_ilu0_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(psb_f_ilu_k_)
! ILU(N) Incomplete LU-factorization with N levels of fill-in. Depending on
! the type of the variant of the algorithm the may be forgotten or added to
! the diagonal (MILU)
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 /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
endif
nrow_a = desc_a%get_local_rows()
nztota = a%get_nzeros()
n_col = desc_a%get_local_cols()
nhalo = n_col-nrow_a
n_row = nrow_a
allocate(lf,uf,stat=info)
if (info == psb_success_) call lf%allocate(n_row,n_row,nztota)
if (info == psb_success_) call uf%allocate(n_row,n_row,nztota)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
allocate(dd(n_row),stat=info)
if (info == psb_success_) then
allocate(prec%dv, stat=info)
if (info == 0) then
if (present(vmold)) then
allocate(prec%dv%v,mold=vmold,stat=info)
else
allocate(psb_c_base_vect_type :: prec%dv%v,stat=info)
end if
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
endif
! This is where we have no renumbering, thus no need
call psb_iluk_fact(fill_in,ialg,a,lf,uf,dd,info)
if(info == psb_success_) then
call prec%av(psb_l_pr_)%mv_from(lf%a)
call prec%av(psb_u_pr_)%mv_from(uf%a)
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()
call prec%dv%bld(dd)
! call move_alloc(dd,prec%d)
else
info=psb_err_from_subroutine_
ch_err='psb_iluk_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(psb_f_ilu_t_)
! ILU(N,E) Incomplete LU factorization with thresholding and level of fill
if (allocated(prec%av)) then
if (size(prec%av) < psb_bp_ilu_avsz) then
@ -513,11 +715,11 @@ subroutine psb_c_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
goto 9999
endif
! This is where we have no renumbering, thus no need
call psb_ilu_fct(a,lf,uf,dd,info)
call psb_ilut_fact(fill_in,fact_eps,a,lf,uf,dd,info,iscale=iscale)
if(info == psb_success_) 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_)%mv_from(lf%a)
call prec%av(psb_u_pr_)%mv_from(uf%a)
call prec%av(psb_l_pr_)%set_asb()
call prec%av(psb_u_pr_)%set_asb()
call prec%av(psb_l_pr_)%trim()
@ -526,7 +728,7 @@ subroutine psb_c_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
! call move_alloc(dd,prec%d)
else
info=psb_err_from_subroutine_
ch_err='psb_ilu_fct'
ch_err='psb_ilut_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@ -590,7 +792,8 @@ subroutine psb_c_bjac_precseti(prec,what,val,info)
case (psb_ilu_fill_in_)
if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.&
& (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then
& ((prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_).or.&
& (prec%iprcparm(psb_f_type_) /= psb_f_ilu_t_))) then
write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
@ -598,6 +801,24 @@ subroutine psb_c_bjac_precseti(prec,what,val,info)
endif
prec%iprcparm(psb_ilu_fill_in_) = val
case (psb_ilu_ialg_)
if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then
write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
return
endif
prec%iprcparm(psb_ilu_ialg_) = val
case (psb_ilu_scale_)
if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then
write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
return
endif
prec%iprcparm(psb_ilu_scale_) = val
case default
write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification'
@ -609,3 +830,57 @@ subroutine psb_c_bjac_precseti(prec,what,val,info)
9999 call psb_error_handler(err_act)
return
end subroutine psb_c_bjac_precseti
subroutine psb_c_bjac_precsetr(prec,what,val,info)
use psb_base_mod
use psb_c_bjacprec, psb_protect_name => psb_c_bjac_precsetr
Implicit None
class(psb_c_bjac_prec_type),intent(inout) :: prec
integer(psb_ipk_), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, nrow
character(len=20) :: name='c_bjac_precset'
call psb_erractionsave(err_act)
info = psb_success_
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(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
return
endif
prec%iprcparm(psb_f_type_) = val
case (psb_fact_eps_)
if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.&
& (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then
write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
return
endif
prec%rprcparm(psb_fact_eps_) = val
case default
write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification'
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_c_bjac_precsetr

295
prec/impl/psb_d_bjacprec_impl.f90
Unescape Escape View File

@ -161,7 +161,7 @@ subroutine psb_d_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work)
associate (wv => prec%wrk(1), wv1 => prec%wrk(2))
select case(prec%iprcparm(psb_f_type_))
case(psb_f_ilu_n_)
case(psb_f_ilu_n_,psb_f_ilu_k_,psb_f_ilu_t_)
select case(trans_)
case('N')
@ -314,7 +314,7 @@ subroutine psb_d_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work)
select case(prec%iprcparm(psb_f_type_))
case(psb_f_ilu_n_)
case(psb_f_ilu_n_,psb_f_ilu_k_,psb_f_ilu_t_)
select case(trans_)
case('N')
@ -389,6 +389,7 @@ subroutine psb_d_bjac_precinit(prec,info)
info = psb_success_
call psb_realloc(psb_ifpsz,prec%iprcparm,info)
call psb_realloc(psb_rfpsz,prec%rprcparm,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_Errpush(info,name)
@ -399,6 +400,11 @@ subroutine psb_d_bjac_precinit(prec,info)
prec%iprcparm(psb_p_type_) = psb_bjac_
prec%iprcparm(psb_f_type_) = psb_f_ilu_n_
prec%iprcparm(psb_ilu_fill_in_) = 0
prec%iprcparm(psb_ilu_ialg_) = psb_ilu_n_
prec%iprcparm(psb_ilu_scale_) = psb_ilu_scale_none_
prec%rprcparm(:) = 0
prec%rprcparm(psb_fact_eps_) = 1E-1_psb_dpk_
call psb_erractionrestore(err_act)
@ -413,7 +419,7 @@ end subroutine psb_d_bjac_precinit
subroutine psb_d_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
use psb_base_mod
use psb_prec_mod, only : psb_ilu_fct
use psb_d_ilu_fact_mod
use psb_d_bjacprec, psb_protect_name => psb_d_bjac_precbld
Implicit None
@ -426,11 +432,12 @@ subroutine psb_d_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
class(psb_i_base_vect_type), intent(in), optional :: imold
! .. Local Scalars ..
integer(psb_ipk_) :: i, m
integer(psb_ipk_) :: i, m, ialg, fill_in, iscale
integer(psb_ipk_) :: ierr(5)
character :: trans, unitd
type(psb_d_csr_sparse_mat), allocatable :: lf, uf
type(psb_dspmat_type), allocatable :: lf, uf
real(psb_dpk_), allocatable :: dd(:)
real(psb_dpk_) :: fact_eps
integer(psb_ipk_) :: nztota, err_act, n_row, nrow_a,n_col, nhalo
integer(psb_ipk_) :: ictxt,np,me
character(len=20) :: name='d_bjac_precbld'
@ -458,9 +465,204 @@ subroutine psb_d_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
trans = 'N'
unitd = 'U'
! We check if all the information contained in the preconditioner structure
! are meaningful, otherwise we give an error and get out of the build
! procedure
ialg = prec%iprcparm(psb_ilu_ialg_)
if ((ialg == psb_ilu_n_).or.(ialg == psb_milu_n_).or.(ialg == psb_ilu_t_)) then
! Do nothing: admissible request
else
info=psb_err_from_subroutine_
ch_err='psb_ilu_ialg_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iscale = prec%iprcparm(psb_ilu_scale_)
if ((iscale == psb_ilu_scale_none_).or.&
(iscale == psb_ilu_scale_maxval_).or.&
(iscale == psb_ilu_scale_diag_).or.&
(iscale == psb_ilu_scale_arwsum_).or.&
(iscale == psb_ilu_scale_aclsum_).or.&
(iscale == psb_ilu_scale_arcsum_)) then
! Do nothing: admissible request
else
info=psb_err_from_subroutine_
ch_err='psb_ilu_scale_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
fact_eps = prec%rprcparm(psb_fact_eps_)
if(fact_eps > 1 ) then
info=psb_err_from_subroutine_
ch_err='psb_fact_eps_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
fill_in = prec%iprcparm(psb_ilu_fill_in_)
if(fill_in < 0) then
info=psb_err_from_subroutine_
ch_err='psb_ilu_fill_in_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
else if (fill_in == 0) then
! If the requested level of fill is equal to zero, we default to the
! specialized ILU(0) routine
prec%iprcparm(psb_f_type_) = psb_f_ilu_n_
end if
! Select on the type of factorization to be used
select case(prec%iprcparm(psb_f_type_))
case(psb_f_ilu_n_)
! ILU(0) Factorization: the total number of nonzeros of the factorized matrix
! is equal to the one of the input matrix
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 /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
endif
nrow_a = desc_a%get_local_rows()
nztota = a%get_nzeros()
n_col = desc_a%get_local_cols()
nhalo = n_col-nrow_a
n_row = nrow_a
allocate(lf,uf,stat=info)
if (info == psb_success_) call lf%allocate(n_row,n_row,nztota)
if (info == psb_success_) call uf%allocate(n_row,n_row,nztota)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
allocate(dd(n_row),stat=info)
if (info == psb_success_) then
allocate(prec%dv, stat=info)
if (info == 0) then
if (present(vmold)) then
allocate(prec%dv%v,mold=vmold,stat=info)
else
allocate(psb_d_base_vect_type :: prec%dv%v,stat=info)
end if
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
endif
! This is where we have no renumbering, thus no need
! call psb_ilu_fct(a,lf,uf,dd,info)
call psb_ilu0_fact(ialg,a,lf,uf,dd,info)
if(info == psb_success_) then
call prec%av(psb_l_pr_)%mv_from(lf%a)
call prec%av(psb_u_pr_)%mv_from(uf%a)
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()
call prec%dv%bld(dd)
! call move_alloc(dd,prec%d)
else
info=psb_err_from_subroutine_
ch_err='psb_ilu0_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(psb_f_ilu_k_)
! ILU(N) Incomplete LU-factorization with N levels of fill-in. Depending on
! the type of the variant of the algorithm the may be forgotten or added to
! the diagonal (MILU)
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 /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
endif
nrow_a = desc_a%get_local_rows()
nztota = a%get_nzeros()
n_col = desc_a%get_local_cols()
nhalo = n_col-nrow_a
n_row = nrow_a
allocate(lf,uf,stat=info)
if (info == psb_success_) call lf%allocate(n_row,n_row,nztota)
if (info == psb_success_) call uf%allocate(n_row,n_row,nztota)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
allocate(dd(n_row),stat=info)
if (info == psb_success_) then
allocate(prec%dv, stat=info)
if (info == 0) then
if (present(vmold)) then
allocate(prec%dv%v,mold=vmold,stat=info)
else
allocate(psb_d_base_vect_type :: prec%dv%v,stat=info)
end if
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
endif
! This is where we have no renumbering, thus no need
call psb_iluk_fact(fill_in,ialg,a,lf,uf,dd,info)
if(info == psb_success_) then
call prec%av(psb_l_pr_)%mv_from(lf%a)
call prec%av(psb_u_pr_)%mv_from(uf%a)
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()
call prec%dv%bld(dd)
! call move_alloc(dd,prec%d)
else
info=psb_err_from_subroutine_
ch_err='psb_iluk_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(psb_f_ilu_t_)
! ILU(N,E) Incomplete LU factorization with thresholding and level of fill
if (allocated(prec%av)) then
if (size(prec%av) < psb_bp_ilu_avsz) then
@ -513,11 +715,11 @@ subroutine psb_d_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
goto 9999
endif
! This is where we have no renumbering, thus no need
call psb_ilu_fct(a,lf,uf,dd,info)
call psb_ilut_fact(fill_in,fact_eps,a,lf,uf,dd,info,iscale=iscale)
if(info == psb_success_) 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_)%mv_from(lf%a)
call prec%av(psb_u_pr_)%mv_from(uf%a)
call prec%av(psb_l_pr_)%set_asb()
call prec%av(psb_u_pr_)%set_asb()
call prec%av(psb_l_pr_)%trim()
@ -526,7 +728,7 @@ subroutine psb_d_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
! call move_alloc(dd,prec%d)
else
info=psb_err_from_subroutine_
ch_err='psb_ilu_fct'
ch_err='psb_ilut_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@ -590,7 +792,8 @@ subroutine psb_d_bjac_precseti(prec,what,val,info)
case (psb_ilu_fill_in_)
if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.&
& (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then
& ((prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_).or.&
& (prec%iprcparm(psb_f_type_) /= psb_f_ilu_t_))) then
write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
@ -598,6 +801,24 @@ subroutine psb_d_bjac_precseti(prec,what,val,info)
endif
prec%iprcparm(psb_ilu_fill_in_) = val
case (psb_ilu_ialg_)
if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then
write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
return
endif
prec%iprcparm(psb_ilu_ialg_) = val
case (psb_ilu_scale_)
if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then
write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
return
endif
prec%iprcparm(psb_ilu_scale_) = val
case default
write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification'
@ -609,3 +830,57 @@ subroutine psb_d_bjac_precseti(prec,what,val,info)
9999 call psb_error_handler(err_act)
return
end subroutine psb_d_bjac_precseti
subroutine psb_d_bjac_precsetr(prec,what,val,info)
use psb_base_mod
use psb_d_bjacprec, psb_protect_name => psb_d_bjac_precsetr
Implicit None
class(psb_d_bjac_prec_type),intent(inout) :: prec
integer(psb_ipk_), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, nrow
character(len=20) :: name='d_bjac_precset'
call psb_erractionsave(err_act)
info = psb_success_
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(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
return
endif
prec%iprcparm(psb_f_type_) = val
case (psb_fact_eps_)
if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.&
& (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then
write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
return
endif
prec%rprcparm(psb_fact_eps_) = val
case default
write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification'
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_d_bjac_precsetr

295
prec/impl/psb_s_bjacprec_impl.f90
Unescape Escape View File

@ -161,7 +161,7 @@ subroutine psb_s_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work)
associate (wv => prec%wrk(1), wv1 => prec%wrk(2))
select case(prec%iprcparm(psb_f_type_))
case(psb_f_ilu_n_)
case(psb_f_ilu_n_,psb_f_ilu_k_,psb_f_ilu_t_)
select case(trans_)
case('N')
@ -314,7 +314,7 @@ subroutine psb_s_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work)
select case(prec%iprcparm(psb_f_type_))
case(psb_f_ilu_n_)
case(psb_f_ilu_n_,psb_f_ilu_k_,psb_f_ilu_t_)
select case(trans_)
case('N')
@ -389,6 +389,7 @@ subroutine psb_s_bjac_precinit(prec,info)
info = psb_success_
call psb_realloc(psb_ifpsz,prec%iprcparm,info)
call psb_realloc(psb_rfpsz,prec%rprcparm,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_Errpush(info,name)
@ -399,6 +400,11 @@ subroutine psb_s_bjac_precinit(prec,info)
prec%iprcparm(psb_p_type_) = psb_bjac_
prec%iprcparm(psb_f_type_) = psb_f_ilu_n_
prec%iprcparm(psb_ilu_fill_in_) = 0
prec%iprcparm(psb_ilu_ialg_) = psb_ilu_n_
prec%iprcparm(psb_ilu_scale_) = psb_ilu_scale_none_
prec%rprcparm(:) = 0
prec%rprcparm(psb_fact_eps_) = 1E-1_psb_spk_
call psb_erractionrestore(err_act)
@ -413,7 +419,7 @@ end subroutine psb_s_bjac_precinit
subroutine psb_s_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
use psb_base_mod
use psb_prec_mod, only : psb_ilu_fct
use psb_s_ilu_fact_mod
use psb_s_bjacprec, psb_protect_name => psb_s_bjac_precbld
Implicit None
@ -426,11 +432,12 @@ subroutine psb_s_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
class(psb_i_base_vect_type), intent(in), optional :: imold
! .. Local Scalars ..
integer(psb_ipk_) :: i, m
integer(psb_ipk_) :: i, m, ialg, fill_in, iscale
integer(psb_ipk_) :: ierr(5)
character :: trans, unitd
type(psb_s_csr_sparse_mat), allocatable :: lf, uf
type(psb_sspmat_type), allocatable :: lf, uf
real(psb_spk_), allocatable :: dd(:)
real(psb_spk_) :: fact_eps
integer(psb_ipk_) :: nztota, err_act, n_row, nrow_a,n_col, nhalo
integer(psb_ipk_) :: ictxt,np,me
character(len=20) :: name='s_bjac_precbld'
@ -458,9 +465,204 @@ subroutine psb_s_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
trans = 'N'
unitd = 'U'
! We check if all the information contained in the preconditioner structure
! are meaningful, otherwise we give an error and get out of the build
! procedure
ialg = prec%iprcparm(psb_ilu_ialg_)
if ((ialg == psb_ilu_n_).or.(ialg == psb_milu_n_).or.(ialg == psb_ilu_t_)) then
! Do nothing: admissible request
else
info=psb_err_from_subroutine_
ch_err='psb_ilu_ialg_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iscale = prec%iprcparm(psb_ilu_scale_)
if ((iscale == psb_ilu_scale_none_).or.&
(iscale == psb_ilu_scale_maxval_).or.&
(iscale == psb_ilu_scale_diag_).or.&
(iscale == psb_ilu_scale_arwsum_).or.&
(iscale == psb_ilu_scale_aclsum_).or.&
(iscale == psb_ilu_scale_arcsum_)) then
! Do nothing: admissible request
else
info=psb_err_from_subroutine_
ch_err='psb_ilu_scale_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
fact_eps = prec%rprcparm(psb_fact_eps_)
if(fact_eps > 1 ) then
info=psb_err_from_subroutine_
ch_err='psb_fact_eps_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
fill_in = prec%iprcparm(psb_ilu_fill_in_)
if(fill_in < 0) then
info=psb_err_from_subroutine_
ch_err='psb_ilu_fill_in_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
else if (fill_in == 0) then
! If the requested level of fill is equal to zero, we default to the
! specialized ILU(0) routine
prec%iprcparm(psb_f_type_) = psb_f_ilu_n_
end if
! Select on the type of factorization to be used
select case(prec%iprcparm(psb_f_type_))
case(psb_f_ilu_n_)
! ILU(0) Factorization: the total number of nonzeros of the factorized matrix
! is equal to the one of the input matrix
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 /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
endif
nrow_a = desc_a%get_local_rows()
nztota = a%get_nzeros()
n_col = desc_a%get_local_cols()
nhalo = n_col-nrow_a
n_row = nrow_a
allocate(lf,uf,stat=info)
if (info == psb_success_) call lf%allocate(n_row,n_row,nztota)
if (info == psb_success_) call uf%allocate(n_row,n_row,nztota)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
allocate(dd(n_row),stat=info)
if (info == psb_success_) then
allocate(prec%dv, stat=info)
if (info == 0) then
if (present(vmold)) then
allocate(prec%dv%v,mold=vmold,stat=info)
else
allocate(psb_s_base_vect_type :: prec%dv%v,stat=info)
end if
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
endif
! This is where we have no renumbering, thus no need
! call psb_ilu_fct(a,lf,uf,dd,info)
call psb_ilu0_fact(ialg,a,lf,uf,dd,info)
if(info == psb_success_) then
call prec%av(psb_l_pr_)%mv_from(lf%a)
call prec%av(psb_u_pr_)%mv_from(uf%a)
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()
call prec%dv%bld(dd)
! call move_alloc(dd,prec%d)
else
info=psb_err_from_subroutine_
ch_err='psb_ilu0_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(psb_f_ilu_k_)
! ILU(N) Incomplete LU-factorization with N levels of fill-in. Depending on
! the type of the variant of the algorithm the may be forgotten or added to
! the diagonal (MILU)
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 /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
endif
nrow_a = desc_a%get_local_rows()
nztota = a%get_nzeros()
n_col = desc_a%get_local_cols()
nhalo = n_col-nrow_a
n_row = nrow_a
allocate(lf,uf,stat=info)
if (info == psb_success_) call lf%allocate(n_row,n_row,nztota)
if (info == psb_success_) call uf%allocate(n_row,n_row,nztota)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
allocate(dd(n_row),stat=info)
if (info == psb_success_) then
allocate(prec%dv, stat=info)
if (info == 0) then
if (present(vmold)) then
allocate(prec%dv%v,mold=vmold,stat=info)
else
allocate(psb_s_base_vect_type :: prec%dv%v,stat=info)
end if
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
endif
! This is where we have no renumbering, thus no need
call psb_iluk_fact(fill_in,ialg,a,lf,uf,dd,info)
if(info == psb_success_) then
call prec%av(psb_l_pr_)%mv_from(lf%a)
call prec%av(psb_u_pr_)%mv_from(uf%a)
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()
call prec%dv%bld(dd)
! call move_alloc(dd,prec%d)
else
info=psb_err_from_subroutine_
ch_err='psb_iluk_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(psb_f_ilu_t_)
! ILU(N,E) Incomplete LU factorization with thresholding and level of fill
if (allocated(prec%av)) then
if (size(prec%av) < psb_bp_ilu_avsz) then
@ -513,11 +715,11 @@ subroutine psb_s_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
goto 9999
endif
! This is where we have no renumbering, thus no need
call psb_ilu_fct(a,lf,uf,dd,info)
call psb_ilut_fact(fill_in,fact_eps,a,lf,uf,dd,info,iscale=iscale)
if(info == psb_success_) 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_)%mv_from(lf%a)
call prec%av(psb_u_pr_)%mv_from(uf%a)
call prec%av(psb_l_pr_)%set_asb()
call prec%av(psb_u_pr_)%set_asb()
call prec%av(psb_l_pr_)%trim()
@ -526,7 +728,7 @@ subroutine psb_s_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
! call move_alloc(dd,prec%d)
else
info=psb_err_from_subroutine_
ch_err='psb_ilu_fct'
ch_err='psb_ilut_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@ -590,7 +792,8 @@ subroutine psb_s_bjac_precseti(prec,what,val,info)
case (psb_ilu_fill_in_)
if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.&
& (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then
& ((prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_).or.&
& (prec%iprcparm(psb_f_type_) /= psb_f_ilu_t_))) then
write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
@ -598,6 +801,24 @@ subroutine psb_s_bjac_precseti(prec,what,val,info)
endif
prec%iprcparm(psb_ilu_fill_in_) = val
case (psb_ilu_ialg_)
if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then
write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
return
endif
prec%iprcparm(psb_ilu_ialg_) = val
case (psb_ilu_scale_)
if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then
write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
return
endif
prec%iprcparm(psb_ilu_scale_) = val
case default
write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification'
@ -609,3 +830,57 @@ subroutine psb_s_bjac_precseti(prec,what,val,info)
9999 call psb_error_handler(err_act)
return
end subroutine psb_s_bjac_precseti
subroutine psb_s_bjac_precsetr(prec,what,val,info)
use psb_base_mod
use psb_s_bjacprec, psb_protect_name => psb_s_bjac_precsetr
Implicit None
class(psb_s_bjac_prec_type),intent(inout) :: prec
integer(psb_ipk_), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, nrow
character(len=20) :: name='s_bjac_precset'
call psb_erractionsave(err_act)
info = psb_success_
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(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
return
endif
prec%iprcparm(psb_f_type_) = val
case (psb_fact_eps_)
if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.&
& (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then
write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
return
endif
prec%rprcparm(psb_fact_eps_) = val
case default
write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification'
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_s_bjac_precsetr

295
prec/impl/psb_z_bjacprec_impl.f90
Unescape Escape View File

@ -161,7 +161,7 @@ subroutine psb_z_bjac_apply_vect(alpha,prec,x,beta,y,desc_data,info,trans,work)
associate (wv => prec%wrk(1), wv1 => prec%wrk(2))
select case(prec%iprcparm(psb_f_type_))
case(psb_f_ilu_n_)
case(psb_f_ilu_n_,psb_f_ilu_k_,psb_f_ilu_t_)
select case(trans_)
case('N')
@ -314,7 +314,7 @@ subroutine psb_z_bjac_apply(alpha,prec,x,beta,y,desc_data,info,trans,work)
select case(prec%iprcparm(psb_f_type_))
case(psb_f_ilu_n_)
case(psb_f_ilu_n_,psb_f_ilu_k_,psb_f_ilu_t_)
select case(trans_)
case('N')
@ -389,6 +389,7 @@ subroutine psb_z_bjac_precinit(prec,info)
info = psb_success_
call psb_realloc(psb_ifpsz,prec%iprcparm,info)
call psb_realloc(psb_rfpsz,prec%rprcparm,info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_Errpush(info,name)
@ -399,6 +400,11 @@ subroutine psb_z_bjac_precinit(prec,info)
prec%iprcparm(psb_p_type_) = psb_bjac_
prec%iprcparm(psb_f_type_) = psb_f_ilu_n_
prec%iprcparm(psb_ilu_fill_in_) = 0
prec%iprcparm(psb_ilu_ialg_) = psb_ilu_n_
prec%iprcparm(psb_ilu_scale_) = psb_ilu_scale_none_
prec%rprcparm(:) = 0
prec%rprcparm(psb_fact_eps_) = 1E-1_psb_dpk_
call psb_erractionrestore(err_act)
@ -413,7 +419,7 @@ end subroutine psb_z_bjac_precinit
subroutine psb_z_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
use psb_base_mod
use psb_prec_mod, only : psb_ilu_fct
use psb_z_ilu_fact_mod
use psb_z_bjacprec, psb_protect_name => psb_z_bjac_precbld
Implicit None
@ -426,11 +432,12 @@ subroutine psb_z_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
class(psb_i_base_vect_type), intent(in), optional :: imold
! .. Local Scalars ..
integer(psb_ipk_) :: i, m
integer(psb_ipk_) :: i, m, ialg, fill_in, iscale
integer(psb_ipk_) :: ierr(5)
character :: trans, unitd
type(psb_z_csr_sparse_mat), allocatable :: lf, uf
type(psb_zspmat_type), allocatable :: lf, uf
complex(psb_dpk_), allocatable :: dd(:)
real(psb_dpk_) :: fact_eps
integer(psb_ipk_) :: nztota, err_act, n_row, nrow_a,n_col, nhalo
integer(psb_ipk_) :: ictxt,np,me
character(len=20) :: name='z_bjac_precbld'
@ -458,9 +465,204 @@ subroutine psb_z_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
trans = 'N'
unitd = 'U'
! We check if all the information contained in the preconditioner structure
! are meaningful, otherwise we give an error and get out of the build
! procedure
ialg = prec%iprcparm(psb_ilu_ialg_)
if ((ialg == psb_ilu_n_).or.(ialg == psb_milu_n_).or.(ialg == psb_ilu_t_)) then
! Do nothing: admissible request
else
info=psb_err_from_subroutine_
ch_err='psb_ilu_ialg_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
iscale = prec%iprcparm(psb_ilu_scale_)
if ((iscale == psb_ilu_scale_none_).or.&
(iscale == psb_ilu_scale_maxval_).or.&
(iscale == psb_ilu_scale_diag_).or.&
(iscale == psb_ilu_scale_arwsum_).or.&
(iscale == psb_ilu_scale_aclsum_).or.&
(iscale == psb_ilu_scale_arcsum_)) then
! Do nothing: admissible request
else
info=psb_err_from_subroutine_
ch_err='psb_ilu_scale_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
fact_eps = prec%rprcparm(psb_fact_eps_)
if(fact_eps > 1 ) then
info=psb_err_from_subroutine_
ch_err='psb_fact_eps_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
fill_in = prec%iprcparm(psb_ilu_fill_in_)
if(fill_in < 0) then
info=psb_err_from_subroutine_
ch_err='psb_ilu_fill_in_'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
else if (fill_in == 0) then
! If the requested level of fill is equal to zero, we default to the
! specialized ILU(0) routine
prec%iprcparm(psb_f_type_) = psb_f_ilu_n_
end if
! Select on the type of factorization to be used
select case(prec%iprcparm(psb_f_type_))
case(psb_f_ilu_n_)
! ILU(0) Factorization: the total number of nonzeros of the factorized matrix
! is equal to the one of the input matrix
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 /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
endif
nrow_a = desc_a%get_local_rows()
nztota = a%get_nzeros()
n_col = desc_a%get_local_cols()
nhalo = n_col-nrow_a
n_row = nrow_a
allocate(lf,uf,stat=info)
if (info == psb_success_) call lf%allocate(n_row,n_row,nztota)
if (info == psb_success_) call uf%allocate(n_row,n_row,nztota)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
allocate(dd(n_row),stat=info)
if (info == psb_success_) then
allocate(prec%dv, stat=info)
if (info == 0) then
if (present(vmold)) then
allocate(prec%dv%v,mold=vmold,stat=info)
else
allocate(psb_z_base_vect_type :: prec%dv%v,stat=info)
end if
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
endif
! This is where we have no renumbering, thus no need
! call psb_ilu_fct(a,lf,uf,dd,info)
call psb_ilu0_fact(ialg,a,lf,uf,dd,info)
if(info == psb_success_) then
call prec%av(psb_l_pr_)%mv_from(lf%a)
call prec%av(psb_u_pr_)%mv_from(uf%a)
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()
call prec%dv%bld(dd)
! call move_alloc(dd,prec%d)
else
info=psb_err_from_subroutine_
ch_err='psb_ilu0_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(psb_f_ilu_k_)
! ILU(N) Incomplete LU-factorization with N levels of fill-in. Depending on
! the type of the variant of the algorithm the may be forgotten or added to
! the diagonal (MILU)
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 /= psb_success_) then
call psb_errpush(psb_err_alloc_dealloc_,name)
goto 9999
end if
endif
nrow_a = desc_a%get_local_rows()
nztota = a%get_nzeros()
n_col = desc_a%get_local_cols()
nhalo = n_col-nrow_a
n_row = nrow_a
allocate(lf,uf,stat=info)
if (info == psb_success_) call lf%allocate(n_row,n_row,nztota)
if (info == psb_success_) call uf%allocate(n_row,n_row,nztota)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
allocate(dd(n_row),stat=info)
if (info == psb_success_) then
allocate(prec%dv, stat=info)
if (info == 0) then
if (present(vmold)) then
allocate(prec%dv%v,mold=vmold,stat=info)
else
allocate(psb_z_base_vect_type :: prec%dv%v,stat=info)
end if
end if
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
endif
! This is where we have no renumbering, thus no need
call psb_iluk_fact(fill_in,ialg,a,lf,uf,dd,info)
if(info == psb_success_) then
call prec%av(psb_l_pr_)%mv_from(lf%a)
call prec%av(psb_u_pr_)%mv_from(uf%a)
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()
call prec%dv%bld(dd)
! call move_alloc(dd,prec%d)
else
info=psb_err_from_subroutine_
ch_err='psb_iluk_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(psb_f_ilu_t_)
! ILU(N,E) Incomplete LU factorization with thresholding and level of fill
if (allocated(prec%av)) then
if (size(prec%av) < psb_bp_ilu_avsz) then
@ -513,11 +715,11 @@ subroutine psb_z_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
goto 9999
endif
! This is where we have no renumbering, thus no need
call psb_ilu_fct(a,lf,uf,dd,info)
call psb_ilut_fact(fill_in,fact_eps,a,lf,uf,dd,info,iscale=iscale)
if(info == psb_success_) 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_)%mv_from(lf%a)
call prec%av(psb_u_pr_)%mv_from(uf%a)
call prec%av(psb_l_pr_)%set_asb()
call prec%av(psb_u_pr_)%set_asb()
call prec%av(psb_l_pr_)%trim()
@ -526,7 +728,7 @@ subroutine psb_z_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold)
! call move_alloc(dd,prec%d)
else
info=psb_err_from_subroutine_
ch_err='psb_ilu_fct'
ch_err='psb_ilut_fact'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
@ -590,7 +792,8 @@ subroutine psb_z_bjac_precseti(prec,what,val,info)
case (psb_ilu_fill_in_)
if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.&
& (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then
& ((prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_).or.&
& (prec%iprcparm(psb_f_type_) /= psb_f_ilu_t_))) then
write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
@ -598,6 +801,24 @@ subroutine psb_z_bjac_precseti(prec,what,val,info)
endif
prec%iprcparm(psb_ilu_fill_in_) = val
case (psb_ilu_ialg_)
if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then
write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
return
endif
prec%iprcparm(psb_ilu_ialg_) = val
case (psb_ilu_scale_)
if (prec%iprcparm(psb_p_type_) /= psb_bjac_) then
write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
return
endif
prec%iprcparm(psb_ilu_scale_) = val
case default
write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification'
@ -609,3 +830,57 @@ subroutine psb_z_bjac_precseti(prec,what,val,info)
9999 call psb_error_handler(err_act)
return
end subroutine psb_z_bjac_precseti
subroutine psb_z_bjac_precsetr(prec,what,val,info)
use psb_base_mod
use psb_z_bjacprec, psb_protect_name => psb_z_bjac_precsetr
Implicit None
class(psb_z_bjac_prec_type),intent(inout) :: prec
integer(psb_ipk_), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act, nrow
character(len=20) :: name='z_bjac_precset'
call psb_erractionsave(err_act)
info = psb_success_
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(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
return
endif
prec%iprcparm(psb_f_type_) = val
case (psb_fact_eps_)
if ((prec%iprcparm(psb_p_type_) /= psb_bjac_).or.&
& (prec%iprcparm(psb_f_type_) /= psb_f_ilu_n_)) then
write(psb_err_unit,*) 'WHAT is invalid for current preconditioner ',&
& prec%iprcparm(psb_p_type_),&
& 'ignoring user specification'
return
endif
prec%rprcparm(psb_fact_eps_) = val
case default
write(psb_err_unit,*) 'WHAT is invalid, ignoring user specification'
end select
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_z_bjac_precsetr

12
prec/psb_c_bjacprec.f90
Unescape Escape View File

@ -36,6 +36,7 @@ module psb_c_bjacprec
type, extends(psb_c_base_prec_type) :: psb_c_bjac_prec_type
integer(psb_ipk_), allocatable :: iprcparm(:)
real(psb_spk_), allocatable :: rprcparm(:)
type(psb_cspmat_type), allocatable :: av(:)
type(psb_c_vect_type), allocatable :: dv, wrk(:)
contains
@ -44,6 +45,7 @@ module psb_c_bjacprec
procedure, pass(prec) :: precbld => psb_c_bjac_precbld
procedure, pass(prec) :: precinit => psb_c_bjac_precinit
procedure, pass(prec) :: precseti => psb_c_bjac_precseti
procedure, pass(prec) :: precsetr => psb_c_bjac_precsetr
procedure, pass(prec) :: precdescr => psb_c_bjac_precdescr
procedure, pass(prec) :: dump => psb_c_bjac_dump
procedure, pass(prec) :: clone => psb_c_bjac_clone
@ -134,6 +136,16 @@ module psb_c_bjacprec
end subroutine psb_c_bjac_precseti
end interface
interface
subroutine psb_c_bjac_precsetr(prec,what,val,info)
import :: psb_ipk_, psb_desc_type, psb_c_bjac_prec_type, psb_c_vect_type, psb_spk_
class(psb_c_bjac_prec_type),intent(inout) :: prec
integer(psb_ipk_), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_bjac_precsetr
end interface
contains

12
prec/psb_d_bjacprec.f90
Unescape Escape View File

@ -36,6 +36,7 @@ module psb_d_bjacprec
type, extends(psb_d_base_prec_type) :: psb_d_bjac_prec_type
integer(psb_ipk_), allocatable :: iprcparm(:)
real(psb_dpk_), allocatable :: rprcparm(:)
type(psb_dspmat_type), allocatable :: av(:)
type(psb_d_vect_type), allocatable :: dv, wrk(:)
contains
@ -44,6 +45,7 @@ module psb_d_bjacprec
procedure, pass(prec) :: precbld => psb_d_bjac_precbld
procedure, pass(prec) :: precinit => psb_d_bjac_precinit
procedure, pass(prec) :: precseti => psb_d_bjac_precseti
procedure, pass(prec) :: precsetr => psb_d_bjac_precsetr
procedure, pass(prec) :: precdescr => psb_d_bjac_precdescr
procedure, pass(prec) :: dump => psb_d_bjac_dump
procedure, pass(prec) :: clone => psb_d_bjac_clone
@ -134,6 +136,16 @@ module psb_d_bjacprec
end subroutine psb_d_bjac_precseti
end interface
interface
subroutine psb_d_bjac_precsetr(prec,what,val,info)
import :: psb_ipk_, psb_desc_type, psb_d_bjac_prec_type, psb_d_vect_type, psb_dpk_
class(psb_d_bjac_prec_type),intent(inout) :: prec
integer(psb_ipk_), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_bjac_precsetr
end interface
contains

6
prec/psb_prec_const_mod.f90
Unescape Escape View File

@ -47,14 +47,16 @@ module psb_prec_const_mod
! levels of fill in for ILU(N),
integer(psb_ipk_), parameter :: psb_p_type_=1, psb_f_type_=2
integer(psb_ipk_), parameter :: psb_ilu_fill_in_=8
integer(psb_ipk_), parameter :: psb_ilu_ialg_=9
!Renumbering. SEE BELOW
integer(psb_ipk_), parameter :: psb_renum_none_=0, psb_renum_glb_=1, psb_renum_gps_=2
integer(psb_ipk_), parameter :: psb_ifpsz=10
! Entries in rprcparm: ILU(E) epsilon, smoother omega
integer(psb_ipk_), parameter :: psb_ilu_scale_=7
integer(psb_ipk_), parameter :: psb_fact_eps_=1
integer(psb_ipk_), parameter :: psb_rfpsz=4
! Factorization types: none, ILU(N), ILU(E)
integer(psb_ipk_), parameter :: psb_f_none_=0,psb_f_ilu_n_=1
! Factorization types: none, ILU(0), ILU(N), ILU(N,E)
integer(psb_ipk_), parameter :: psb_f_none_=0,psb_f_ilu_n_=1,psb_f_ilu_k_=2,psb_f_ilu_t_=3
! Fields for sparse matrices ensembles:
integer(psb_ipk_), parameter :: psb_l_pr_=1, psb_u_pr_=2, psb_bp_ilu_avsz=2
integer(psb_ipk_), parameter :: psb_max_avsz=psb_bp_ilu_avsz

12
prec/psb_s_bjacprec.f90
Unescape Escape View File

@ -36,6 +36,7 @@ module psb_s_bjacprec
type, extends(psb_s_base_prec_type) :: psb_s_bjac_prec_type
integer(psb_ipk_), allocatable :: iprcparm(:)
real(psb_spk_), allocatable :: rprcparm(:)
type(psb_sspmat_type), allocatable :: av(:)
type(psb_s_vect_type), allocatable :: dv, wrk(:)
contains
@ -44,6 +45,7 @@ module psb_s_bjacprec
procedure, pass(prec) :: precbld => psb_s_bjac_precbld
procedure, pass(prec) :: precinit => psb_s_bjac_precinit
procedure, pass(prec) :: precseti => psb_s_bjac_precseti
procedure, pass(prec) :: precsetr => psb_s_bjac_precsetr
procedure, pass(prec) :: precdescr => psb_s_bjac_precdescr
procedure, pass(prec) :: dump => psb_s_bjac_dump
procedure, pass(prec) :: clone => psb_s_bjac_clone
@ -134,6 +136,16 @@ module psb_s_bjacprec
end subroutine psb_s_bjac_precseti
end interface
interface
subroutine psb_s_bjac_precsetr(prec,what,val,info)
import :: psb_ipk_, psb_desc_type, psb_s_bjac_prec_type, psb_s_vect_type, psb_spk_
class(psb_s_bjac_prec_type),intent(inout) :: prec
integer(psb_ipk_), intent(in) :: what
real(psb_spk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_bjac_precsetr
end interface
contains

12
prec/psb_z_bjacprec.f90
Unescape Escape View File

@ -36,6 +36,7 @@ module psb_z_bjacprec
type, extends(psb_z_base_prec_type) :: psb_z_bjac_prec_type
integer(psb_ipk_), allocatable :: iprcparm(:)
real(psb_dpk_), allocatable :: rprcparm(:)
type(psb_zspmat_type), allocatable :: av(:)
type(psb_z_vect_type), allocatable :: dv, wrk(:)
contains
@ -44,6 +45,7 @@ module psb_z_bjacprec
procedure, pass(prec) :: precbld => psb_z_bjac_precbld
procedure, pass(prec) :: precinit => psb_z_bjac_precinit
procedure, pass(prec) :: precseti => psb_z_bjac_precseti
procedure, pass(prec) :: precsetr => psb_z_bjac_precsetr
procedure, pass(prec) :: precdescr => psb_z_bjac_precdescr
procedure, pass(prec) :: dump => psb_z_bjac_dump
procedure, pass(prec) :: clone => psb_z_bjac_clone
@ -134,6 +136,16 @@ module psb_z_bjacprec
end subroutine psb_z_bjac_precseti
end interface
interface
subroutine psb_z_bjac_precsetr(prec,what,val,info)
import :: psb_ipk_, psb_desc_type, psb_z_bjac_prec_type, psb_z_vect_type, psb_dpk_
class(psb_z_bjac_prec_type),intent(inout) :: prec
integer(psb_ipk_), intent(in) :: what
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_bjac_precsetr
end interface
contains

54
test/pargen/psb_d_pde3d.f90
Unescape Escape View File

@ -604,6 +604,14 @@ program psb_d_pde3d
integer(psb_epk_) :: amatsize, precsize, descsize, d2size
real(psb_dpk_) :: err, eps
! Parameters for solvers in Block-Jacobi preconditioner
type ainvparms
character(len=12) :: alg, orth_alg
integer(psb_ipk_) :: fill, inv_fill
real(psb_dpk_) :: thresh, inv_thresh
end type ainvparms
type(ainvparms) :: parms
! other variables
integer(psb_ipk_) :: info, i
character(len=20) :: name,ch_err
@ -633,7 +641,7 @@ program psb_d_pde3d
!
! get parameters
!
call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart)
call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart,parms)
!
! allocate and fill in the coefficient matrix, rhs and initial guess
@ -745,13 +753,15 @@ contains
!
! get iteration parameters from standard input
!
subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart)
subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,&
itmax,itrace,irst,ipart,parms)
integer(psb_ipk_) :: ictxt
character(len=*) :: kmethd, ptype, afmt
integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst,ipart
integer(psb_ipk_) :: np, iam
integer(psb_ipk_) :: ip, inp_unit
character(len=1024) :: filename
type(ainvparms) :: parms
call psb_info(ictxt, iam, np)
@ -802,6 +812,21 @@ contains
else
irst=1
endif
if (ip >= 9) then
read(psb_inp_unit,*) parms%alg
read(psb_inp_unit,*) parms%fill
read(psb_inp_unit,*) parms%inv_fill
read(psb_inp_unit,*) parms%thresh
read(psb_inp_unit,*) parms%inv_thresh
read(psb_inp_unit,*) parms%orth_alg
else
parms%alg = 'ILU' ! AINV variant: ILU,ILUT,MILU,INVK,AINVT,AORTH
parms%fill = 0 ! Fill in for forward factorization
parms%inv_fill = 1 ! Fill in for inverse factorization
parms%thresh = 1E-1_psb_dpk_ ! Threshold for forward factorization
parms%inv_thresh = 1E-1_psb_dpk_ ! Threshold for inverse factorization
parms%orth_alg = 'LLK' ! What orthogonalization algorithm?
endif
write(psb_out_unit,'("Solving matrix : ell1")')
write(psb_out_unit,&
@ -818,6 +843,23 @@ contains
write(psb_out_unit,'("Unknown data distrbution, defaulting to 3D")')
end select
write(psb_out_unit,'("Preconditioner : ",a)') ptype
if( psb_toupper(ptype) == "BJAC" ) then
write(psb_out_unit,'("Block subsolver : ",a)') parms%alg
select case (psb_toupper(parms%alg))
case ('ILU','ILUT','MILU')
write(psb_out_unit,'("Fill in : ",i0)') parms%fill
write(psb_out_unit,'("Threshold : ",e2.2)') parms%thresh
case ('INVK')
write(psb_out_unit,'("Fill : ",i0)') parms%fill
write(psb_out_unit,'("Threshold : ",e2.2)') parms%thresh
write(psb_out_unit,'("Invese Fill : ",i0)') parms%inv_fill
write(psb_out_unit,'("Inverse Threshold : ",e2.2)') parms%inv_thresh
case ('AINVT','AORTH')
write(psb_out_unit,'("Inverse Threshold : ",e2.2)') parms%inv_thresh
case default
write(psb_out_unit,'("Unknown diagonal solver")')
end select
end if
write(psb_out_unit,'("Iterative method : ",a)') kmethd
write(psb_out_unit,'(" ")')
else
@ -841,6 +883,12 @@ contains
call psb_bcast(ictxt,itmax)
call psb_bcast(ictxt,itrace)
call psb_bcast(ictxt,irst)
call psb_bcast(ictxt,parms%alg)
call psb_bcast(ictxt,parms%fill)
call psb_bcast(ictxt,parms%inv_fill)
call psb_bcast(ictxt,parms%thresh)
call psb_bcast(ictxt,parms%inv_thresh)
call psb_bcast(ictxt,parms%orth_alg)
return
@ -868,5 +916,3 @@ contains
end subroutine pr_usage
end program psb_d_pde3d

54
test/pargen/psb_s_pde3d.f90
Unescape Escape View File

@ -604,6 +604,14 @@ program psb_s_pde3d
integer(psb_epk_) :: amatsize, precsize, descsize, d2size
real(psb_spk_) :: err, eps
! Parameters for solvers in Block-Jacobi preconditioner
type ainvparms
character(len=12) :: alg, orth_alg
integer(psb_ipk_) :: fill, inv_fill
real(psb_dpk_) :: thresh, inv_thresh
end type ainvparms
type(ainvparms) :: parms
! other variables
integer(psb_ipk_) :: info, i
character(len=20) :: name,ch_err
@ -633,7 +641,7 @@ program psb_s_pde3d
!
! get parameters
!
call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart)
call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart,parms)
!
! allocate and fill in the coefficient matrix, rhs and initial guess
@ -745,13 +753,15 @@ contains
!
! get iteration parameters from standard input
!
subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart)
subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,&
itmax,itrace,irst,ipart,parms)
integer(psb_ipk_) :: ictxt
character(len=*) :: kmethd, ptype, afmt
integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst,ipart
integer(psb_ipk_) :: np, iam
integer(psb_ipk_) :: ip, inp_unit
character(len=1024) :: filename
type(ainvparms) :: parms
call psb_info(ictxt, iam, np)
@ -802,6 +812,21 @@ contains
else
irst=1
endif
if (ip >= 9) then
read(psb_inp_unit,*) parms%alg
read(psb_inp_unit,*) parms%fill
read(psb_inp_unit,*) parms%inv_fill
read(psb_inp_unit,*) parms%thresh
read(psb_inp_unit,*) parms%inv_thresh
read(psb_inp_unit,*) parms%orth_alg
else
parms%alg = 'ILU' ! AINV variant: ILU,ILUT,MILU,INVK,AINVT,AORTH
parms%fill = 0 ! Fill in for forward factorization
parms%inv_fill = 1 ! Fill in for inverse factorization
parms%thresh = 1E-1_psb_spk_ ! Threshold for forward factorization
parms%inv_thresh = 1E-1_psb_spk_ ! Threshold for inverse factorization
parms%orth_alg = 'LLK' ! What orthogonalization algorithm?
endif
write(psb_out_unit,'("Solving matrix : ell1")')
write(psb_out_unit,&
@ -818,6 +843,23 @@ contains
write(psb_out_unit,'("Unknown data distrbution, defaulting to 3D")')
end select
write(psb_out_unit,'("Preconditioner : ",a)') ptype
if( psb_toupper(ptype) == "BJAC" ) then
write(psb_out_unit,'("Block subsolver : ",a)') parms%alg
select case (psb_toupper(parms%alg))
case ('ILU','ILUT','MILU')
write(psb_out_unit,'("Fill in : ",i0)') parms%fill
write(psb_out_unit,'("Threshold : ",e2.2)') parms%thresh
case ('INVK')
write(psb_out_unit,'("Fill : ",i0)') parms%fill
write(psb_out_unit,'("Threshold : ",e2.2)') parms%thresh
write(psb_out_unit,'("Invese Fill : ",i0)') parms%inv_fill
write(psb_out_unit,'("Inverse Threshold : ",e2.2)') parms%inv_thresh
case ('AINVT','AORTH')
write(psb_out_unit,'("Inverse Threshold : ",e2.2)') parms%inv_thresh
case default
write(psb_out_unit,'("Unknown diagonal solver")')
end select
end if
write(psb_out_unit,'("Iterative method : ",a)') kmethd
write(psb_out_unit,'(" ")')
else
@ -841,6 +883,12 @@ contains
call psb_bcast(ictxt,itmax)
call psb_bcast(ictxt,itrace)
call psb_bcast(ictxt,irst)
call psb_bcast(ictxt,parms%alg)
call psb_bcast(ictxt,parms%fill)
call psb_bcast(ictxt,parms%inv_fill)
call psb_bcast(ictxt,parms%thresh)
call psb_bcast(ictxt,parms%inv_thresh)
call psb_bcast(ictxt,parms%orth_alg)
return
@ -868,5 +916,3 @@ contains
end subroutine pr_usage
end program psb_s_pde3d

6
test/pargen/runs/ppde.inp
Unescape Escape View File

@ -8,5 +8,11 @@ CSR Storage format for matrix A: CSR COO
0100 MAXIT
05 ITRACE
002 IRST restart for RGMRES and BiCGSTABL
ILU Factorization variant: ILU,ILUT,MILU,INVK,AINVT,AORTH
0 Fill in for forward factorization
1 Fill in for inverse factorization (ignored if not INVK)
1E-1 Threshold for forward factorization (ignored if ILU)
1E-1 Threshold for inverse factorization (ignored if ILU,ILUT,MILU)
LLK What orthogonalization algorithm? (ignored if ILU,ILUT,MILU,INVK)

Write Preview
Loading…
Cancel
Save