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

mld2p4-2:

Browse Source 
Makefile
 mld_d_ilu_solver.f03
 mld_zaggrmap_bld.f90
 mld_zilu0_fact.f90
 mld_ziluk_fact.f90
 mld_zilut_fact.f90

Further advance on double complex.
stopcriterion
Salvatore Filippone 14 years ago
parent f92e7157cb
commit 84aa2586bc
6 changed files with 566 additions and 527 deletions
Show Stats Download Patch File Download Diff File

1
mlprec/Makefile
Unescape Escape View File

@ -28,6 +28,7 @@ INNEROBJS= mld_dcoarse_bld.o mld_dmlprec_bld.o mld_dslu_bld.o mld_dumf_bld.o \
mld_cilu0_fact.o mld_ciluk_fact.o mld_cilut_fact.o mld_caggrmap_bld.o \ mld_cilu0_fact.o mld_ciluk_fact.o mld_cilut_fact.o mld_caggrmap_bld.o \
mld_cmlprec_aply.o mld_cslud_bld.o mld_caggrmat_asb.o \ mld_cmlprec_aply.o mld_cslud_bld.o mld_caggrmat_asb.o \
mld_zcoarse_bld.o mld_zmlprec_bld.o mld_zslu_bld.o mld_zumf_bld.o \ mld_zcoarse_bld.o mld_zmlprec_bld.o mld_zslu_bld.o mld_zumf_bld.o \
mld_zilu0_fact.o mld_ziluk_fact.o mld_zilut_fact.o mld_zaggrmap_bld.o \
$(MPFOBJS) $(MPFOBJS)
# #

2
mlprec/mld_d_ilu_solver.f03
Unescape Escape View File

@ -48,7 +48,7 @@ module mld_d_ilu_solver
use mld_d_prec_type use mld_d_prec_type
type, extends(mld_d_base_solver_type) :: mld_d_ilu_solver_type type, extends(mld_d_base_solver_type) :: mld_d_ilu_solver_type
type(psb_dspmat_type) :: l, u type(psb_dspmat_type) :: l, u
real(psb_dpk_), allocatable :: d(:) real(psb_dpk_), allocatable :: d(:)
integer :: fact_type, fill_in integer :: fact_type, fill_in
real(psb_dpk_) :: thresh real(psb_dpk_) :: thresh

34
mlprec/mld_zaggrmap_bld.f90
Unescape Escape View File

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

488
mlprec/mld_zilu0_fact.f90
Unescape Escape View File

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

260
mlprec/mld_ziluk_fact.f90
Unescape Escape View File

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

308
mlprec/mld_zilut_fact.f90
Unescape Escape View File

@ -95,7 +95,7 @@
subroutine mld_zilut_fact(fill_in,thres,a,l,u,d,info,blck) subroutine mld_zilut_fact(fill_in,thres,a,l,u,d,info,blck)
use psb_sparse_mod use psb_sparse_mod
use mld_inner_mod, mld_protect_name => mld_zilut_fact use mld_inner_mod!, mld_protect_name => mld_zilut_fact
implicit none implicit none
@ -112,6 +112,7 @@ subroutine mld_zilut_fact(fill_in,thres,a,l,u,d,info,blck)
integer :: l1, l2, m, err_act integer :: l1, l2, m, err_act
type(psb_zspmat_type), pointer :: blck_ type(psb_zspmat_type), pointer :: blck_
type(psb_z_csr_sparse_mat) :: ll, uu
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='mld_zilut_fact' name='mld_zilut_fact'
@ -130,26 +131,32 @@ subroutine mld_zilut_fact(fill_in,thres,a,l,u,d,info,blck)
blck_ => blck blck_ => blck
else else
allocate(blck_,stat=info) allocate(blck_,stat=info)
if (info /= psb_success_) then if (info == psb_success_) call blck_%csall(0,0,info,1)
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
call psb_sp_all(0,0,blck_,1,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_sp_all' ch_err='csall'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
endif endif
m = a%get_nrows() + blck_%get_nrows()
if ((m /= l%get_nrows()).or.(m /= u%get_nrows()).or.&
& (m > size(d)) ) then
write(0,*) 'Wrong allocation status for L,D,U? ',&
& l%get_nrows(),size(d),u%get_nrows()
info = -1
return
end if
call l%mv_to(ll)
call u%mv_to(uu)
! !
! Compute the ILU(k,t) factorization ! Compute the ILU(k,t) factorization
! !
call mld_zilut_factint(fill_in,thres,m,a,blck_,& call mld_zilut_factint(fill_in,thres,a,blck_,&
& d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) & d,ll%val,ll%ja,ll%irp,uu%val,uu%ja,uu%irp,l1,l2,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mld_zilut_factint' ch_err='mld_zilut_factint'
@ -160,31 +167,29 @@ subroutine mld_zilut_fact(fill_in,thres,a,l,u,d,info,blck)
! !
! Store information on the L and U sparse matrices ! Store information on the L and U sparse matrices
! !
l%infoa(1) = l1 call l%mv_from(ll)
l%fida = 'CSR' call l%set_triangle()
l%descra = 'TLU' call l%set_unit()
u%infoa(1) = l2 call l%set_lower()
u%fida = 'CSR' call u%mv_from(uu)
u%descra = 'TUU' call u%set_triangle()
l%m = m call u%set_unit()
l%k = m call u%set_upper()
u%m = m
u%k = m
! !
! Nullify the pointer / deallocate the memory ! Nullify pointer / deallocate memory
! !
if (present(blck)) then if (present(blck)) then
blck_ => null() blck_ => null()
else else
call psb_sp_free(blck_,info) call blck_%free()
if (info /= psb_success_) then deallocate(blck_,stat=info)
info=psb_err_from_subroutine_ if(info.ne.0) then
ch_err='psb_sp_free' info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err=ch_err) ch_err='psb_sp_free'
goto 9999 call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if end if
deallocate(blck_)
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -241,53 +246,53 @@ contains
! d - complex(psb_dpk_), dimension(:), output. ! d - complex(psb_dpk_), dimension(:), output.
! The inverse of the diagonal entries of the U factor in the incomplete ! The inverse of the diagonal entries of the U factor in the incomplete
! factorization. ! factorization.
! laspk - complex(psb_dpk_), dimension(:), input/output. ! lval - complex(psb_dpk_), dimension(:), input/output.
! The L factor in the incomplete factorization. ! The L factor in the incomplete factorization.
! lia1 - integer, dimension(:), input/output. ! lia1 - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the L factor, ! The column indices of the nonzero entries of the L factor,
! according to the CSR storage format. ! according to the CSR storage format.
! lia2 - integer, dimension(:), input/output. ! lirp - integer, dimension(:), input/output.
! The indices identifying the first nonzero entry of each row ! The indices identifying the first nonzero entry of each row
! of the L factor in laspk, according to the CSR storage format. ! of the L factor in lval, according to the CSR storage format.
! uaspk - complex(psb_dpk_), dimension(:), input/output. ! uval - complex(psb_dpk_), dimension(:), input/output.
! The U factor in the incomplete factorization. ! The U factor in the incomplete factorization.
! The entries of U are stored according to the CSR format. ! The entries of U are stored according to the CSR format.
! uia1 - integer, dimension(:), input/output. ! uja - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the U factor, ! The column indices of the nonzero entries of the U factor,
! according to the CSR storage format. ! according to the CSR storage format.
! uia2 - integer, dimension(:), input/output. ! uirp - integer, dimension(:), input/output.
! The indices identifying the first nonzero entry of each row ! The indices identifying the first nonzero entry of each row
! of the U factor in uaspk, according to the CSR storage format. ! of the U factor in uval, according to the CSR storage format.
! l1 - integer, output ! l1 - integer, output
! The number of nonzero entries in laspk. ! The number of nonzero entries in lval.
! l2 - integer, output ! l2 - integer, output
! The number of nonzero entries in uaspk. ! The number of nonzero entries in uval.
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_zilut_factint(fill_in,thres,m,a,b,& subroutine mld_zilut_factint(fill_in,thres,a,b,&
& d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info) & d,lval,lja,lirp,uval,uja,uirp,l1,l2,info)
use psb_sparse_mod use psb_sparse_mod
implicit none implicit none
! Arguments ! Arguments
integer, intent(in) :: fill_in integer, intent(in) :: fill_in
real(psb_dpk_), intent(in) :: thres real(psb_dpk_), intent(in) :: thres
type(psb_zspmat_type), intent(in) :: a,b type(psb_zspmat_type),intent(in) :: a,b
integer, intent(inout) :: m,l1,l2,info integer,intent(inout) :: l1,l2,info
integer, allocatable, intent(inout) :: lia1(:),lia2(:),uia1(:),uia2(:) integer, allocatable, intent(inout) :: lja(:),lirp(:),uja(:),uirp(:)
complex(psb_dpk_), allocatable, intent(inout) :: laspk(:),uaspk(:) complex(psb_dpk_), allocatable, intent(inout) :: lval(:),uval(:)
complex(psb_dpk_), intent(inout) :: d(:) complex(psb_dpk_), intent(inout) :: d(:)
! Local Variables ! Local Variables
integer :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb integer :: i, ktrw,err_act,nidx,nlw,nup,jmaxup, ma, mb, m
real(psb_dpk_) :: nrmi real(psb_dpk_) :: nrmi
integer, allocatable :: idxs(:) integer, allocatable :: idxs(:)
complex(psb_dpk_), allocatable :: row(:) complex(psb_dpk_), allocatable :: row(:)
type(psb_int_heap) :: heap type(psb_int_heap) :: heap
type(psb_zspmat_type) :: trw type(psb_z_coo_sparse_mat) :: trw
character(len=20), parameter :: name='mld_zilut_factint' character(len=20), parameter :: name='mld_zilut_factint'
character(len=20) :: ch_err character(len=20) :: ch_err
@ -296,16 +301,16 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ma = a%m ma = a%get_nrows()
mb = b%m mb = b%get_nrows()
m = ma+mb m = ma+mb
! !
! Allocate a temporary buffer for the ilut_copyin function ! Allocate a temporary buffer for the ilut_copyin function
! !
call psb_sp_all(0,0,trw,1,info) call trw%allocate(0,0,1)
if (info == psb_success_) call psb_ensure_size(m+1,lia2,info) if (info == psb_success_) call psb_ensure_size(m+1,lirp,info)
if (info == psb_success_) call psb_ensure_size(m+1,uia2,info) if (info == psb_success_) call psb_ensure_size(m+1,uirp,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
@ -315,8 +320,8 @@ contains
l1=0 l1=0
l2=0 l2=0
lia2(1) = 1 lirp(1) = 1
uia2(1) = 1 uirp(1) = 1
! !
! Allocate memory to hold the entries of a row ! Allocate memory to hold the entries of a row
@ -354,12 +359,12 @@ contains
! Do an elimination step on current row ! Do an elimination step on current row
! !
if (info == psb_success_) call ilut_fact(thres,i,nrmi,row,heap,& if (info == psb_success_) call ilut_fact(thres,i,nrmi,row,heap,&
& d,uia1,uia2,uaspk,nidx,idxs,info) & d,uja,uirp,uval,nidx,idxs,info)
! !
! Copy the row into laspk/d(i)/uaspk ! Copy the row into lval/d(i)/uval
! !
if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row,nidx,idxs,& if (info == psb_success_) call ilut_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row,nidx,idxs,&
& l1,l2,lia1,lia2,laspk,d,uia1,uia2,uaspk,info) & l1,l2,lja,lirp,lval,d,uja,uirp,uval,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_internal_error_ info=psb_err_internal_error_
@ -378,7 +383,7 @@ contains
call psb_errpush(info,name,a_err='Deallocate') call psb_errpush(info,name,a_err='Deallocate')
goto 9999 goto 9999
end if end if
if (info == psb_success_) call psb_sp_free(trw,info) if (info == psb_success_) call trw%free()
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_sp_free' ch_err='psb_sp_free'
@ -482,17 +487,17 @@ contains
subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,nrmi,row,heap,ktrw,trw,info) subroutine ilut_copyin(i,m,a,jd,jmin,jmax,nlw,nup,jmaxup,nrmi,row,heap,ktrw,trw,info)
use psb_sparse_mod use psb_sparse_mod
implicit none implicit none
type(psb_zspmat_type), intent(in) :: a type(psb_zspmat_type), intent(in) :: a
type(psb_zspmat_type), intent(inout) :: trw type(psb_z_coo_sparse_mat), intent(inout) :: trw
integer, intent(in) :: i, m,jmin,jmax,jd integer, intent(in) :: i, m,jmin,jmax,jd
integer, intent(inout) :: ktrw,nlw,nup,jmaxup,info integer, intent(inout) :: ktrw,nlw,nup,jmaxup,info
real(psb_dpk_), intent(inout) :: nrmi real(psb_dpk_), intent(inout) :: nrmi
complex(psb_dpk_), intent(inout) :: row(:) complex(psb_dpk_), intent(inout) :: row(:)
type(psb_int_heap), intent(inout) :: heap type(psb_int_heap), intent(inout) :: heap
integer :: k,j,irb,kin,nz integer :: k,j,irb,kin,nz
integer, parameter :: nrb=16 integer, parameter :: nrb=40
real(psb_dpk_) :: dmaxup real(psb_dpk_) :: dmaxup
real(psb_dpk_), external :: dznrm2 real(psb_dpk_), external :: dznrm2
character(len=20), parameter :: name='mld_zilut_factint' character(len=20), parameter :: name='mld_zilut_factint'
@ -517,25 +522,21 @@ contains
nlw = 0 nlw = 0
nup = 0 nup = 0
jmaxup = 0 jmaxup = 0
dmaxup = dzero dmaxup = szero
nrmi = dzero nrmi = szero
if (psb_toupper(a%fida) == 'CSR') then select type (aa=> a%a)
type is (psb_z_csr_sparse_mat)
! !
! Take a fast shortcut if the matrix is stored in CSR format ! Take a fast shortcut if the matrix is stored in CSR format
! !
do j = a%ia2(i), a%ia2(i+1) - 1 do j = aa%irp(i), aa%irp(i+1) - 1
k = a%ia1(j) k = aa%ja(j)
if ((jmin<=k).and.(k<=jmax)) then if ((jmin<=k).and.(k<=jmax)) then
row(k) = a%aspk(j) row(k) = aa%val(j)
call psb_insert_heap(k,heap,info) call psb_insert_heap(k,heap,info)
if (info /= psb_success_) then if (info /= psb_success_) exit
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_insert_heap')
goto 9999
end if
end if end if
if (k<jd) nlw = nlw + 1 if (k<jd) nlw = nlw + 1
if (k>jd) then if (k>jd) then
@ -546,9 +547,17 @@ contains
end if end if
end if end if
end do end do
nz = a%ia2(i+1) - a%ia2(i) if (info /= psb_success_) then
nrmi = dznrm2(nz,a%aspk(a%ia2(i)),ione) info=psb_err_from_subroutine_
else call psb_errpush(info,name,a_err='psb_insert_heap')
goto 9999
end if
nz = aa%irp(i+1) - aa%irp(i)
nrmi = dznrm2(nz,aa%val(aa%irp(i)),ione)
class default
! !
! Otherwise use psb_sp_getblk, slower but able (in principle) of ! Otherwise use psb_sp_getblk, slower but able (in principle) of
@ -560,7 +569,7 @@ contains
if ((mod(i,nrb) == 1).or.(nrb == 1)) then if ((mod(i,nrb) == 1).or.(nrb == 1)) then
irb = min(m-i+1,nrb) irb = min(m-i+1,nrb)
call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1) call aa%csget(i,i+irb-1,trw,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_sp_getblk') call psb_errpush(info,name,a_err='psb_sp_getblk')
@ -570,18 +579,16 @@ contains
end if end if
kin = ktrw kin = ktrw
nz = trw%get_nzeros()
do do
if (ktrw > trw%infoa(psb_nnz_)) exit if (ktrw > nz) exit
if (trw%ia1(ktrw) > i) exit if (trw%ia(ktrw) > i) exit
k = trw%ia2(ktrw) k = trw%ja(ktrw)
if ((jmin<=k).and.(k<=jmax)) then if ((jmin<=k).and.(k<=jmax)) then
row(k) = trw%aspk(ktrw) row(k) = trw%val(ktrw)
call psb_insert_heap(k,heap,info) call psb_insert_heap(k,heap,info)
if (info /= psb_success_) then if (info /= psb_success_) exit
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_insert_heap')
goto 9999
end if
end if end if
if (k<jd) nlw = nlw + 1 if (k<jd) nlw = nlw + 1
if (k>jd) then if (k>jd) then
@ -594,8 +601,9 @@ contains
ktrw = ktrw + 1 ktrw = ktrw + 1
enddo enddo
nz = ktrw - kin nz = ktrw - kin
nrmi = dznrm2(nz,trw%aspk(kin),ione) nrmi = dznrm2(nz,trw%val(kin),ione)
end if end select
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -645,17 +653,17 @@ contains
! d - complex(psb_dpk_), input. ! d - complex(psb_dpk_), input.
! The inverse of the diagonal entries of the part of the U factor ! The inverse of the diagonal entries of the part of the U factor
! above the current row (see ilut_copyout). ! above the current row (see ilut_copyout).
! uia1 - integer, dimension(:), input. ! uja - integer, dimension(:), input.
! The column indices of the nonzero entries of the part of the U ! The column indices of the nonzero entries of the part of the U
! factor above the current row, stored in uaspk row by row (see ! factor above the current row, stored in uval row by row (see
! ilut_copyout, called by mld_zilut_factint), according to the CSR ! ilut_copyout, called by mld_zilut_factint), according to the CSR
! storage format. ! storage format.
! uia2 - integer, dimension(:), input. ! uirp - integer, dimension(:), input.
! The indices identifying the first nonzero entry of each row of ! The indices identifying the first nonzero entry of each row of
! the U factor above the current row, stored in uaspk row by row ! the U factor above the current row, stored in uval row by row
! (see ilut_copyout, called by mld_zilut_factint), according to ! (see ilut_copyout, called by mld_zilut_factint), according to
! the CSR storage format. ! the CSR storage format.
! uaspk - complex(psb_dpk_), dimension(:), input. ! uval - complex(psb_dpk_), dimension(:), input.
! The entries of the U factor above the current row (except the ! The entries of the U factor above the current row (except the
! diagonal ones), stored according to the CSR format. ! diagonal ones), stored according to the CSR format.
! nidx - integer, output. ! nidx - integer, output.
@ -669,7 +677,7 @@ contains
! Note: this argument is intent(inout) and not only intent(out) ! Note: this argument is intent(inout) and not only intent(out)
! to retain its allocation, done by this routine. ! to retain its allocation, done by this routine.
! !
subroutine ilut_fact(thres,i,nrmi,row,heap,d,uia1,uia2,uaspk,nidx,idxs,info) subroutine ilut_fact(thres,i,nrmi,row,heap,d,uja,uirp,uval,nidx,idxs,info)
use psb_sparse_mod use psb_sparse_mod
@ -681,8 +689,8 @@ contains
integer, intent(inout) :: nidx,info integer, intent(inout) :: nidx,info
real(psb_dpk_), intent(in) :: thres,nrmi real(psb_dpk_), intent(in) :: thres,nrmi
integer, allocatable, intent(inout) :: idxs(:) integer, allocatable, intent(inout) :: idxs(:)
integer, intent(inout) :: uia1(:),uia2(:) integer, intent(inout) :: uja(:),uirp(:)
complex(psb_dpk_), intent(inout) :: row(:), uaspk(:),d(:) complex(psb_dpk_), intent(inout) :: row(:), uval(:),d(:)
! Local Variables ! Local Variables
integer :: k,j,jj,lastk, iret integer :: k,j,jj,lastk, iret
@ -726,8 +734,8 @@ contains
! Note: since U is scaled while copying it out (see ilut_copyout), ! Note: since U is scaled while copying it out (see ilut_copyout),
! we can use rwk in the update below. ! we can use rwk in the update below.
! !
do jj=uia2(k),uia2(k+1)-1 do jj=uirp(k),uirp(k+1)-1
j = uia1(jj) j = uja(jj)
if (j<=k) then if (j<=k) then
info = -i info = -i
return return
@ -736,7 +744,7 @@ contains
! Update row(j) and, if it is not to be discarded, insert ! Update row(j) and, if it is not to be discarded, insert
! its index into the heap for further processing. ! its index into the heap for further processing.
! !
row(j) = row(j) - rwk * uaspk(jj) row(j) = row(j) - rwk * uval(jj)
if (abs(row(j)) < thres*nrmi) then if (abs(row(j)) < thres*nrmi) then
! !
! Drop the entry. ! Drop the entry.
@ -771,8 +779,8 @@ contains
! Note: internal subroutine of mld_zilut_fact ! Note: internal subroutine of mld_zilut_fact
! !
! This routine copies a matrix row, computed by ilut_fact by applying an ! This routine copies a matrix row, computed by ilut_fact by applying an
! elimination step of the ILU(k,t) factorization, into the arrays laspk, ! elimination step of the ILU(k,t) factorization, into the arrays lval,
! uaspk, d, corresponding to the L factor, the U factor and the diagonal ! uval, d, corresponding to the L factor, the U factor and the diagonal
! of U, respectively. ! of U, respectively.
! !
! Note that ! Note that
@ -781,11 +789,11 @@ contains
! the 'lower part' of the row, and the nup+k ones in the 'upper part'; ! the 'lower part' of the row, and the nup+k ones in the 'upper part';
! - the entry in the upper part of the row which has maximum absolute value ! - the entry in the upper part of the row which has maximum absolute value
! in the original matrix is included in the above nup+k entries anyway; ! in the original matrix is included in the above nup+k entries anyway;
! - the part of the row stored into uaspk is scaled by the corresponding ! - the part of the row stored into uval is scaled by the corresponding
! diagonal entry, according to the LDU form of the incomplete factorization; ! diagonal entry, according to the LDU form of the incomplete factorization;
! - the inverse of the diagonal entries of U is actually stored into d; this ! - the inverse of the diagonal entries of U is actually stored into d; this
! is then managed in the solve stage associated to the ILU(k,t) factorization; ! is then managed in the solve stage associated to the ILU(k,t) factorization;
! - the row entries are stored in laspk and uaspk according to the CSR format; ! - the row entries are stored in lval and uval according to the CSR format;
! - the array row is re-initialized for future use in mld_ilut_fact(see also ! - the array row is re-initialized for future use in mld_ilut_fact(see also
! ilut_copyin and ilut_fact). ! ilut_copyin and ilut_fact).
! !
@ -825,49 +833,49 @@ contains
! examined during the elimination step carried out by the routine ! examined during the elimination step carried out by the routine
! ilut_fact. ! ilut_fact.
! l1 - integer, input/output. ! l1 - integer, input/output.
! Pointer to the last occupied entry of laspk. ! Pointer to the last occupied entry of lval.
! l2 - integer, input/output. ! l2 - integer, input/output.
! Pointer to the last occupied entry of uaspk. ! Pointer to the last occupied entry of uval.
! lia1 - integer, dimension(:), input/output. ! lja - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the L factor, ! The column indices of the nonzero entries of the L factor,
! copied in laspk row by row (see mld_zilut_factint), according ! copied in lval row by row (see mld_zilut_factint), according
! to the CSR storage format. ! to the CSR storage format.
! lia2 - integer, dimension(:), input/output. ! lirp - integer, dimension(:), input/output.
! The indices identifying the first nonzero entry of each row ! The indices identifying the first nonzero entry of each row
! of the L factor, copied in laspk row by row (see ! of the L factor, copied in lval row by row (see
! mld_zilut_factint), according to the CSR storage format. ! mld_zilut_factint), according to the CSR storage format.
! laspk - complex(psb_dpk_), dimension(:), input/output. ! lval - complex(psb_dpk_), dimension(:), input/output.
! The array where the entries of the row corresponding to the ! The array where the entries of the row corresponding to the
! L factor are copied. ! L factor are copied.
! d - complex(psb_dpk_), dimension(:), input/output. ! d - complex(psb_dpk_), dimension(:), input/output.
! The array where the inverse of the diagonal entry of the ! The array where the inverse of the diagonal entry of the
! row is copied (only d(i) is used by the routine). ! row is copied (only d(i) is used by the routine).
! uia1 - integer, dimension(:), input/output. ! uja - integer, dimension(:), input/output.
! The column indices of the nonzero entries of the U factor ! The column indices of the nonzero entries of the U factor
! copied in uaspk row by row (see mld_zilut_factint), according ! copied in uval row by row (see mld_zilut_factint), according
! to the CSR storage format. ! to the CSR storage format.
! uia2 - integer, dimension(:), input/output. ! uirp - integer, dimension(:), input/output.
! The indices identifying the first nonzero entry of each row ! The indices identifying the first nonzero entry of each row
! of the U factor copied in uaspk row by row (see ! of the U factor copied in uval row by row (see
! mld_zilu_fctint), according to the CSR storage format. ! mld_zilu_fctint), according to the CSR storage format.
! uaspk - complex(psb_dpk_), dimension(:), input/output. ! uval - complex(psb_dpk_), dimension(:), input/output.
! The array where the entries of the row corresponding to the ! The array where the entries of the row corresponding to the
! U factor are copied. ! U factor are copied.
! !
subroutine ilut_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row, & subroutine ilut_copyout(fill_in,thres,i,m,nlw,nup,jmaxup,nrmi,row, &
& nidx,idxs,l1,l2,lia1,lia2,laspk,d,uia1,uia2,uaspk,info) & nidx,idxs,l1,l2,lja,lirp,lval,d,uja,uirp,uval,info)
use psb_sparse_mod use psb_sparse_mod
implicit none implicit none
! Arguments ! Arguments
integer, intent(in) :: fill_in,i,m,nidx,nlw,nup,jmaxup integer, intent(in) :: fill_in,i,m,nidx,nlw,nup,jmaxup
integer, intent(in) :: idxs(:) integer, intent(in) :: idxs(:)
integer, intent(inout) :: l1,l2, info integer, intent(inout) :: l1,l2, info
integer, allocatable, intent(inout) :: uia1(:),uia2(:), lia1(:),lia2(:) integer, allocatable, intent(inout) :: uja(:),uirp(:), lja(:),lirp(:)
real(psb_dpk_), intent(in) :: thres,nrmi real(psb_dpk_), intent(in) :: thres,nrmi
complex(psb_dpk_),allocatable, intent(inout) :: uaspk(:), laspk(:) complex(psb_dpk_),allocatable, intent(inout) :: uval(:), lval(:)
complex(psb_dpk_), intent(inout) :: row(:), d(:) complex(psb_dpk_), intent(inout) :: row(:), d(:)
! Local variables ! Local variables
@ -966,21 +974,21 @@ contains
! !
do k=1,nz do k=1,nz
l1 = l1 + 1 l1 = l1 + 1
if (size(laspk) < l1) then if (size(lval) < l1) then
! !
! Figure out a good reallocation size! ! Figure out a good reallocation size!
! !
isz = (max((l1/i)*m,int(1.2*l1),l1+100)) isz = (max((l1/i)*m,int(1.2*l1),l1+100))
call psb_realloc(isz,laspk,info) call psb_realloc(isz,lval,info)
if (info == psb_success_) call psb_realloc(isz,lia1,info) if (info == psb_success_) call psb_realloc(isz,lja,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate') call psb_errpush(info,name,a_err='Allocate')
goto 9999 goto 9999
end if end if
end if end if
lia1(l1) = xwid(k) lja(l1) = xwid(k)
laspk(l1) = xw(indx(k)) lval(l1) = xw(indx(k))
end do end do
! !
@ -1022,7 +1030,7 @@ contains
! !
! Compute 1/pivot ! Compute 1/pivot
! !
d(i) = done/d(i) d(i) = zone/d(i)
end if end if
end if end if
end if end if
@ -1112,21 +1120,21 @@ contains
! !
do k=1,nz do k=1,nz
l2 = l2 + 1 l2 = l2 + 1
if (size(uaspk) < l2) then if (size(uval) < l2) then
! !
! Figure out a good reallocation size! ! Figure out a good reallocation size!
! !
isz = max((l2/i)*m,int(1.2*l2),l2+100) isz = max((l2/i)*m,int(1.2*l2),l2+100)
call psb_realloc(isz,uaspk,info) call psb_realloc(isz,uval,info)
if (info == psb_success_) call psb_realloc(isz,uia1,info) if (info == psb_success_) call psb_realloc(isz,uja,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Allocate') call psb_errpush(info,name,a_err='Allocate')
goto 9999 goto 9999
end if end if
end if end if
uia1(l2) = xwid(k) uja(l2) = xwid(k)
uaspk(l2) = d(i)*xw(indx(k)) uval(l2) = d(i)*xw(indx(k))
end do end do
! !
@ -1138,10 +1146,10 @@ contains
! !
! Store the pointers to the first non occupied entry of in ! Store the pointers to the first non occupied entry of in
! laspk and uaspk ! lval and uval
! !
lia2(i+1) = l1 + 1 lirp(i+1) = l1 + 1
uia2(i+1) = l2 + 1 uirp(i+1) = l2 + 1
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

Write Preview
Loading…
Cancel
Save