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

Merge pull request #1 from sfilippone/level-wrk

Browse Source 
Level wrk
stopcriterion
Salvatore Filippone 7 years ago committed by GitHub
parent da89066c21 9fe63d8387
commit b1d1780142
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
117 changed files with 5376 additions and 4108 deletions
Show Stats Download Patch File Download Diff File

1129
mlprec/impl/mld_cmlprec_aply.f90
View File

File diff suppressed because it is too large Load Diff

155
mlprec/impl/mld_cprecaply.f90
Unescape Escape View File

@ -323,6 +323,7 @@ subroutine mld_cprecaply2_vect(prec,x,y,desc_data,info,trans,work)
complex(psb_spk_), pointer :: work_(:)
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: err_act,iwsz, k, nswps
logical :: do_alloc_wrk
character(len=20) :: name
name='mld_cprecaply'
@ -358,6 +359,10 @@ subroutine mld_cprecaply2_vect(prec,x,y,desc_data,info,trans,work)
call psb_errpush(info,name)
goto 9999
end if
do_alloc_wrk = .not.allocated(prec%precv(1)%wrk)
if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
if (size(prec%precv) >1) then
!
! Number of levels > 1: apply the multilevel preconditioner
@ -375,31 +380,29 @@ subroutine mld_cprecaply2_vect(prec,x,y,desc_data,info,trans,work)
!
nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post)
if (allocated(prec%precv(1)%sm2a)) then
!
! This is a kludge for handling the symmetrized GS case.
! Will need some rethinking.
!
twoside: block
type(psb_c_vect_type) :: w1,w2
call psb_geasb(w1,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(w2,desc_data,info,mold=x%v,scratch=.true.)
associate(w1 => prec%precv(1)%wrk%vx2l, w2 => prec%precv(1)%wrk%vy2l,&
& wv => prec%precv(1)%wrk%wv)
if (allocated(prec%precv(1)%sm2a)) then
!
! This is a kludge for handling the symmetrized GS case.
! Will need some rethinking.
!
call psb_geaxpby(cone,x,czero,w1,desc_data,info)
select case(trans_)
case ('N')
do k=1, nswps
call prec%precv(1)%sm%apply(cone,w1,czero,w2,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(cone,w2,czero,w1,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
end do
case('T','C')
do k=1, nswps
call prec%precv(1)%sm2a%apply(cone,w1,czero,w2,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
call prec%precv(1)%sm%apply(cone,w2,czero,w1,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
end do
case default
info = psb_err_from_subroutine_
@ -407,14 +410,12 @@ subroutine mld_cprecaply2_vect(prec,x,y,desc_data,info,trans,work)
goto 9999
end select
call psb_geaxpby(cone,w1,czero,y,desc_data,info)
call psb_gefree(w1,desc_data,info)
call psb_gefree(w2,desc_data,info)
end block twoside
else
call prec%precv(1)%sm%apply(cone,x,czero,y,desc_data,trans_,&
& nswps,work_,info)
end if
else
call prec%precv(1)%sm%apply(cone,x,czero,y,desc_data,trans_,&
& nswps,work_,wv,info)
end if
end associate
else
info = psb_err_from_subroutine_ai_
@ -426,6 +427,7 @@ subroutine mld_cprecaply2_vect(prec,x,y,desc_data,info,trans,work)
! If the original distribution has an overlap we should fix that.
call psb_halo(y,desc_data,info,data=psb_comm_mov_)
if (do_alloc_wrk) call prec%free_wrk(info)
if (present(work)) then
else
@ -459,10 +461,10 @@ subroutine mld_cprecaply1_vect(prec,x,desc_data,info,trans,work)
! Local variables
character :: trans_
type(psb_c_vect_type) :: ww
complex(psb_spk_), pointer :: work_(:)
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: err_act,iwsz, k, nswps
logical :: do_alloc_wrk
character(len=20) :: name
name='mld_cprecaply'
@ -498,67 +500,72 @@ subroutine mld_cprecaply1_vect(prec,x,desc_data,info,trans,work)
call psb_errpush(info,name)
goto 9999
end if
call psb_geasb(ww,desc_data,info,mold=x%v,scratch=.true.)
if (size(prec%precv) >1) then
!
! Number of levels > 1: apply the multilevel preconditioner
!
call mld_mlprec_aply(cone,prec,x,czero,ww,desc_data,trans_,work_,info)
if (info == 0) call psb_geaxpby(cone,ww,czero,x,desc_data,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_cmlprec_aply')
goto 9999
end if
do_alloc_wrk = .not.allocated(prec%precv(1)%wrk)
if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
else if (size(prec%precv) == 1) then
!
! Number of levels = 1: apply the base preconditioner
!
nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post)
if (allocated(prec%precv(1)%sm2a)) then
associate(ww => prec%precv(1)%wrk%vtx, wv => prec%precv(1)%wrk%wv)
if (size(prec%precv) >1) then
!
! This is a kludge for handling the symmetrized GS case.
! Will need some rethinking.
! Number of levels > 1: apply the multilevel preconditioner
!
select case(trans_)
case ('N')
do k=1, nswps
call prec%precv(1)%sm%apply(cone,x,czero,ww,desc_data,trans_,&
& ione, work_,info)
call prec%precv(1)%sm2a%apply(cone,ww,czero,x,desc_data,trans_,&
& ione, work_,info)
end do
case('T','C')
do k=1, nswps
call prec%precv(1)%sm2a%apply(cone,x,czero,ww,desc_data,trans_,&
& ione, work_,info)
call prec%precv(1)%sm%apply(cone,ww,czero,x,desc_data,trans_,&
& ione, work_,info)
end do
case default
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Invalid trans')
goto 9999
end select
else
call prec%precv(1)%sm%apply(cone,x,czero,ww,desc_data,trans_,&
& nswps, work_,info)
call mld_mlprec_aply(cone,prec,x,czero,ww,desc_data,trans_,work_,info)
if (info == 0) call psb_geaxpby(cone,ww,czero,x,desc_data,info)
end if
else
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_cmlprec_aply')
goto 9999
end if
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
endif
else if (size(prec%precv) == 1) then
!
! Number of levels = 1: apply the base preconditioner
!
nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post)
if (allocated(prec%precv(1)%sm2a)) then
!
! This is a kludge for handling the symmetrized GS case.
! Will need some rethinking.
!
select case(trans_)
case ('N')
do k=1, nswps
call prec%precv(1)%sm%apply(cone,x,czero,ww,desc_data,trans_,&
& ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(cone,ww,czero,x,desc_data,trans_,&
& ione, work_,wv,info)
end do
case('T','C')
do k=1, nswps
call prec%precv(1)%sm2a%apply(cone,x,czero,ww,desc_data,trans_,&
& ione, work_,wv,info)
call prec%precv(1)%sm%apply(cone,ww,czero,x,desc_data,trans_,&
& ione, work_,wv,info)
end do
case default
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Invalid trans')
goto 9999
end select
if (info == 0) call psb_gefree(ww,desc_data,info)
else
call prec%precv(1)%sm%apply(cone,x,czero,ww,desc_data,trans_,&
& nswps, work_,wv,info)
if (info == 0) call psb_geaxpby(cone,ww,czero,x,desc_data,info)
end if
else
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
endif
end associate
! If the original distribution has an overlap we should fix that.
call psb_halo(x,desc_data,info,data=psb_comm_mov_)
if (do_alloc_wrk) call prec%free_wrk(info)
if (present(work)) then
else

4
mlprec/impl/mld_cprecset.F90
Unescape Escape View File

@ -432,7 +432,7 @@ subroutine mld_cprecsetsm(p,val,info,ilev,ilmax,pos)
! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin_, ilmax_
character(len=*), parameter :: name='mld_precseti'
character(len=*), parameter :: name='mld_precsetsm'
info = psb_success_
@ -495,7 +495,7 @@ subroutine mld_cprecsetsv(p,val,info,ilev,ilmax,pos)
! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin_, ilmax_
character(len=*), parameter :: name='mld_precseti'
character(len=*), parameter :: name='mld_precsetsv'
info = psb_success_

1129
mlprec/impl/mld_dmlprec_aply.f90
View File

File diff suppressed because it is too large Load Diff

155
mlprec/impl/mld_dprecaply.f90
Unescape Escape View File

@ -323,6 +323,7 @@ subroutine mld_dprecaply2_vect(prec,x,y,desc_data,info,trans,work)
real(psb_dpk_), pointer :: work_(:)
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: err_act,iwsz, k, nswps
logical :: do_alloc_wrk
character(len=20) :: name
name='mld_dprecaply'
@ -358,6 +359,10 @@ subroutine mld_dprecaply2_vect(prec,x,y,desc_data,info,trans,work)
call psb_errpush(info,name)
goto 9999
end if
do_alloc_wrk = .not.allocated(prec%precv(1)%wrk)
if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
if (size(prec%precv) >1) then
!
! Number of levels > 1: apply the multilevel preconditioner
@ -375,31 +380,29 @@ subroutine mld_dprecaply2_vect(prec,x,y,desc_data,info,trans,work)
!
nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post)
if (allocated(prec%precv(1)%sm2a)) then
!
! This is a kludge for handling the symmetrized GS case.
! Will need some rethinking.
!
twoside: block
type(psb_d_vect_type) :: w1,w2
call psb_geasb(w1,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(w2,desc_data,info,mold=x%v,scratch=.true.)
associate(w1 => prec%precv(1)%wrk%vx2l, w2 => prec%precv(1)%wrk%vy2l,&
& wv => prec%precv(1)%wrk%wv)
if (allocated(prec%precv(1)%sm2a)) then
!
! This is a kludge for handling the symmetrized GS case.
! Will need some rethinking.
!
call psb_geaxpby(done,x,dzero,w1,desc_data,info)
select case(trans_)
case ('N')
do k=1, nswps
call prec%precv(1)%sm%apply(done,w1,dzero,w2,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(done,w2,dzero,w1,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
end do
case('T','C')
do k=1, nswps
call prec%precv(1)%sm2a%apply(done,w1,dzero,w2,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
call prec%precv(1)%sm%apply(done,w2,dzero,w1,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
end do
case default
info = psb_err_from_subroutine_
@ -407,14 +410,12 @@ subroutine mld_dprecaply2_vect(prec,x,y,desc_data,info,trans,work)
goto 9999
end select
call psb_geaxpby(done,w1,dzero,y,desc_data,info)
call psb_gefree(w1,desc_data,info)
call psb_gefree(w2,desc_data,info)
end block twoside
else
call prec%precv(1)%sm%apply(done,x,dzero,y,desc_data,trans_,&
& nswps,work_,info)
end if
else
call prec%precv(1)%sm%apply(done,x,dzero,y,desc_data,trans_,&
& nswps,work_,wv,info)
end if
end associate
else
info = psb_err_from_subroutine_ai_
@ -426,6 +427,7 @@ subroutine mld_dprecaply2_vect(prec,x,y,desc_data,info,trans,work)
! If the original distribution has an overlap we should fix that.
call psb_halo(y,desc_data,info,data=psb_comm_mov_)
if (do_alloc_wrk) call prec%free_wrk(info)
if (present(work)) then
else
@ -459,10 +461,10 @@ subroutine mld_dprecaply1_vect(prec,x,desc_data,info,trans,work)
! Local variables
character :: trans_
type(psb_d_vect_type) :: ww
real(psb_dpk_), pointer :: work_(:)
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: err_act,iwsz, k, nswps
logical :: do_alloc_wrk
character(len=20) :: name
name='mld_dprecaply'
@ -498,67 +500,72 @@ subroutine mld_dprecaply1_vect(prec,x,desc_data,info,trans,work)
call psb_errpush(info,name)
goto 9999
end if
call psb_geasb(ww,desc_data,info,mold=x%v,scratch=.true.)
if (size(prec%precv) >1) then
!
! Number of levels > 1: apply the multilevel preconditioner
!
call mld_mlprec_aply(done,prec,x,dzero,ww,desc_data,trans_,work_,info)
if (info == 0) call psb_geaxpby(done,ww,dzero,x,desc_data,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_dmlprec_aply')
goto 9999
end if
do_alloc_wrk = .not.allocated(prec%precv(1)%wrk)
if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
else if (size(prec%precv) == 1) then
!
! Number of levels = 1: apply the base preconditioner
!
nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post)
if (allocated(prec%precv(1)%sm2a)) then
associate(ww => prec%precv(1)%wrk%vtx, wv => prec%precv(1)%wrk%wv)
if (size(prec%precv) >1) then
!
! This is a kludge for handling the symmetrized GS case.
! Will need some rethinking.
! Number of levels > 1: apply the multilevel preconditioner
!
select case(trans_)
case ('N')
do k=1, nswps
call prec%precv(1)%sm%apply(done,x,dzero,ww,desc_data,trans_,&
& ione, work_,info)
call prec%precv(1)%sm2a%apply(done,ww,dzero,x,desc_data,trans_,&
& ione, work_,info)
end do
case('T','C')
do k=1, nswps
call prec%precv(1)%sm2a%apply(done,x,dzero,ww,desc_data,trans_,&
& ione, work_,info)
call prec%precv(1)%sm%apply(done,ww,dzero,x,desc_data,trans_,&
& ione, work_,info)
end do
case default
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Invalid trans')
goto 9999
end select
else
call prec%precv(1)%sm%apply(done,x,dzero,ww,desc_data,trans_,&
& nswps, work_,info)
call mld_mlprec_aply(done,prec,x,dzero,ww,desc_data,trans_,work_,info)
if (info == 0) call psb_geaxpby(done,ww,dzero,x,desc_data,info)
end if
else
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_dmlprec_aply')
goto 9999
end if
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
endif
else if (size(prec%precv) == 1) then
!
! Number of levels = 1: apply the base preconditioner
!
nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post)
if (allocated(prec%precv(1)%sm2a)) then
!
! This is a kludge for handling the symmetrized GS case.
! Will need some rethinking.
!
select case(trans_)
case ('N')
do k=1, nswps
call prec%precv(1)%sm%apply(done,x,dzero,ww,desc_data,trans_,&
& ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(done,ww,dzero,x,desc_data,trans_,&
& ione, work_,wv,info)
end do
case('T','C')
do k=1, nswps
call prec%precv(1)%sm2a%apply(done,x,dzero,ww,desc_data,trans_,&
& ione, work_,wv,info)
call prec%precv(1)%sm%apply(done,ww,dzero,x,desc_data,trans_,&
& ione, work_,wv,info)
end do
case default
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Invalid trans')
goto 9999
end select
if (info == 0) call psb_gefree(ww,desc_data,info)
else
call prec%precv(1)%sm%apply(done,x,dzero,ww,desc_data,trans_,&
& nswps, work_,wv,info)
if (info == 0) call psb_geaxpby(done,ww,dzero,x,desc_data,info)
end if
else
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
endif
end associate
! If the original distribution has an overlap we should fix that.
call psb_halo(x,desc_data,info,data=psb_comm_mov_)
if (do_alloc_wrk) call prec%free_wrk(info)
if (present(work)) then
else

4
mlprec/impl/mld_dprecset.F90
Unescape Escape View File

@ -465,7 +465,7 @@ subroutine mld_dprecsetsm(p,val,info,ilev,ilmax,pos)
! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin_, ilmax_
character(len=*), parameter :: name='mld_precseti'
character(len=*), parameter :: name='mld_precsetsm'
info = psb_success_
@ -528,7 +528,7 @@ subroutine mld_dprecsetsv(p,val,info,ilev,ilmax,pos)
! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin_, ilmax_
character(len=*), parameter :: name='mld_precseti'
character(len=*), parameter :: name='mld_precsetsv'
info = psb_success_

1129
mlprec/impl/mld_smlprec_aply.f90
View File

File diff suppressed because it is too large Load Diff

155
mlprec/impl/mld_sprecaply.f90
Unescape Escape View File

@ -323,6 +323,7 @@ subroutine mld_sprecaply2_vect(prec,x,y,desc_data,info,trans,work)
real(psb_spk_), pointer :: work_(:)
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: err_act,iwsz, k, nswps
logical :: do_alloc_wrk
character(len=20) :: name
name='mld_sprecaply'
@ -358,6 +359,10 @@ subroutine mld_sprecaply2_vect(prec,x,y,desc_data,info,trans,work)
call psb_errpush(info,name)
goto 9999
end if
do_alloc_wrk = .not.allocated(prec%precv(1)%wrk)
if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
if (size(prec%precv) >1) then
!
! Number of levels > 1: apply the multilevel preconditioner
@ -375,31 +380,29 @@ subroutine mld_sprecaply2_vect(prec,x,y,desc_data,info,trans,work)
!
nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post)
if (allocated(prec%precv(1)%sm2a)) then
!
! This is a kludge for handling the symmetrized GS case.
! Will need some rethinking.
!
twoside: block
type(psb_s_vect_type) :: w1,w2
call psb_geasb(w1,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(w2,desc_data,info,mold=x%v,scratch=.true.)
associate(w1 => prec%precv(1)%wrk%vx2l, w2 => prec%precv(1)%wrk%vy2l,&
& wv => prec%precv(1)%wrk%wv)
if (allocated(prec%precv(1)%sm2a)) then
!
! This is a kludge for handling the symmetrized GS case.
! Will need some rethinking.
!
call psb_geaxpby(sone,x,szero,w1,desc_data,info)
select case(trans_)
case ('N')
do k=1, nswps
call prec%precv(1)%sm%apply(sone,w1,szero,w2,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(sone,w2,szero,w1,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
end do
case('T','C')
do k=1, nswps
call prec%precv(1)%sm2a%apply(sone,w1,szero,w2,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
call prec%precv(1)%sm%apply(sone,w2,szero,w1,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
end do
case default
info = psb_err_from_subroutine_
@ -407,14 +410,12 @@ subroutine mld_sprecaply2_vect(prec,x,y,desc_data,info,trans,work)
goto 9999
end select
call psb_geaxpby(sone,w1,szero,y,desc_data,info)
call psb_gefree(w1,desc_data,info)
call psb_gefree(w2,desc_data,info)
end block twoside
else
call prec%precv(1)%sm%apply(sone,x,szero,y,desc_data,trans_,&
& nswps,work_,info)
end if
else
call prec%precv(1)%sm%apply(sone,x,szero,y,desc_data,trans_,&
& nswps,work_,wv,info)
end if
end associate
else
info = psb_err_from_subroutine_ai_
@ -426,6 +427,7 @@ subroutine mld_sprecaply2_vect(prec,x,y,desc_data,info,trans,work)
! If the original distribution has an overlap we should fix that.
call psb_halo(y,desc_data,info,data=psb_comm_mov_)
if (do_alloc_wrk) call prec%free_wrk(info)
if (present(work)) then
else
@ -459,10 +461,10 @@ subroutine mld_sprecaply1_vect(prec,x,desc_data,info,trans,work)
! Local variables
character :: trans_
type(psb_s_vect_type) :: ww
real(psb_spk_), pointer :: work_(:)
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: err_act,iwsz, k, nswps
logical :: do_alloc_wrk
character(len=20) :: name
name='mld_sprecaply'
@ -498,67 +500,72 @@ subroutine mld_sprecaply1_vect(prec,x,desc_data,info,trans,work)
call psb_errpush(info,name)
goto 9999
end if
call psb_geasb(ww,desc_data,info,mold=x%v,scratch=.true.)
if (size(prec%precv) >1) then
!
! Number of levels > 1: apply the multilevel preconditioner
!
call mld_mlprec_aply(sone,prec,x,szero,ww,desc_data,trans_,work_,info)
if (info == 0) call psb_geaxpby(sone,ww,szero,x,desc_data,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_smlprec_aply')
goto 9999
end if
do_alloc_wrk = .not.allocated(prec%precv(1)%wrk)
if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
else if (size(prec%precv) == 1) then
!
! Number of levels = 1: apply the base preconditioner
!
nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post)
if (allocated(prec%precv(1)%sm2a)) then
associate(ww => prec%precv(1)%wrk%vtx, wv => prec%precv(1)%wrk%wv)
if (size(prec%precv) >1) then
!
! This is a kludge for handling the symmetrized GS case.
! Will need some rethinking.
! Number of levels > 1: apply the multilevel preconditioner
!
select case(trans_)
case ('N')
do k=1, nswps
call prec%precv(1)%sm%apply(sone,x,szero,ww,desc_data,trans_,&
& ione, work_,info)
call prec%precv(1)%sm2a%apply(sone,ww,szero,x,desc_data,trans_,&
& ione, work_,info)
end do
case('T','C')
do k=1, nswps
call prec%precv(1)%sm2a%apply(sone,x,szero,ww,desc_data,trans_,&
& ione, work_,info)
call prec%precv(1)%sm%apply(sone,ww,szero,x,desc_data,trans_,&
& ione, work_,info)
end do
case default
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Invalid trans')
goto 9999
end select
else
call prec%precv(1)%sm%apply(sone,x,szero,ww,desc_data,trans_,&
& nswps, work_,info)
call mld_mlprec_aply(sone,prec,x,szero,ww,desc_data,trans_,work_,info)
if (info == 0) call psb_geaxpby(sone,ww,szero,x,desc_data,info)
end if
else
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_smlprec_aply')
goto 9999
end if
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
endif
else if (size(prec%precv) == 1) then
!
! Number of levels = 1: apply the base preconditioner
!
nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post)
if (allocated(prec%precv(1)%sm2a)) then
!
! This is a kludge for handling the symmetrized GS case.
! Will need some rethinking.
!
select case(trans_)
case ('N')
do k=1, nswps
call prec%precv(1)%sm%apply(sone,x,szero,ww,desc_data,trans_,&
& ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(sone,ww,szero,x,desc_data,trans_,&
& ione, work_,wv,info)
end do
case('T','C')
do k=1, nswps
call prec%precv(1)%sm2a%apply(sone,x,szero,ww,desc_data,trans_,&
& ione, work_,wv,info)
call prec%precv(1)%sm%apply(sone,ww,szero,x,desc_data,trans_,&
& ione, work_,wv,info)
end do
case default
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Invalid trans')
goto 9999
end select
if (info == 0) call psb_gefree(ww,desc_data,info)
else
call prec%precv(1)%sm%apply(sone,x,szero,ww,desc_data,trans_,&
& nswps, work_,wv,info)
if (info == 0) call psb_geaxpby(sone,ww,szero,x,desc_data,info)
end if
else
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
endif
end associate
! If the original distribution has an overlap we should fix that.
call psb_halo(x,desc_data,info,data=psb_comm_mov_)
if (do_alloc_wrk) call prec%free_wrk(info)
if (present(work)) then
else

4
mlprec/impl/mld_sprecset.F90
Unescape Escape View File

@ -432,7 +432,7 @@ subroutine mld_sprecsetsm(p,val,info,ilev,ilmax,pos)
! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin_, ilmax_
character(len=*), parameter :: name='mld_precseti'
character(len=*), parameter :: name='mld_precsetsm'
info = psb_success_
@ -495,7 +495,7 @@ subroutine mld_sprecsetsv(p,val,info,ilev,ilmax,pos)
! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin_, ilmax_
character(len=*), parameter :: name='mld_precseti'
character(len=*), parameter :: name='mld_precsetsv'
info = psb_success_

1129
mlprec/impl/mld_zmlprec_aply.f90
View File

File diff suppressed because it is too large Load Diff

155
mlprec/impl/mld_zprecaply.f90
Unescape Escape View File

@ -323,6 +323,7 @@ subroutine mld_zprecaply2_vect(prec,x,y,desc_data,info,trans,work)
complex(psb_dpk_), pointer :: work_(:)
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: err_act,iwsz, k, nswps
logical :: do_alloc_wrk
character(len=20) :: name
name='mld_zprecaply'
@ -358,6 +359,10 @@ subroutine mld_zprecaply2_vect(prec,x,y,desc_data,info,trans,work)
call psb_errpush(info,name)
goto 9999
end if
do_alloc_wrk = .not.allocated(prec%precv(1)%wrk)
if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
if (size(prec%precv) >1) then
!
! Number of levels > 1: apply the multilevel preconditioner
@ -375,31 +380,29 @@ subroutine mld_zprecaply2_vect(prec,x,y,desc_data,info,trans,work)
!
nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post)
if (allocated(prec%precv(1)%sm2a)) then
!
! This is a kludge for handling the symmetrized GS case.
! Will need some rethinking.
!
twoside: block
type(psb_z_vect_type) :: w1,w2
call psb_geasb(w1,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(w2,desc_data,info,mold=x%v,scratch=.true.)
associate(w1 => prec%precv(1)%wrk%vx2l, w2 => prec%precv(1)%wrk%vy2l,&
& wv => prec%precv(1)%wrk%wv)
if (allocated(prec%precv(1)%sm2a)) then
!
! This is a kludge for handling the symmetrized GS case.
! Will need some rethinking.
!
call psb_geaxpby(zone,x,zzero,w1,desc_data,info)
select case(trans_)
case ('N')
do k=1, nswps
call prec%precv(1)%sm%apply(zone,w1,zzero,w2,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(zone,w2,zzero,w1,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
end do
case('T','C')
do k=1, nswps
call prec%precv(1)%sm2a%apply(zone,w1,zzero,w2,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
call prec%precv(1)%sm%apply(zone,w2,zzero,w1,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
end do
case default
info = psb_err_from_subroutine_
@ -407,14 +410,12 @@ subroutine mld_zprecaply2_vect(prec,x,y,desc_data,info,trans,work)
goto 9999
end select
call psb_geaxpby(zone,w1,zzero,y,desc_data,info)
call psb_gefree(w1,desc_data,info)
call psb_gefree(w2,desc_data,info)
end block twoside
else
call prec%precv(1)%sm%apply(zone,x,zzero,y,desc_data,trans_,&
& nswps,work_,info)
end if
else
call prec%precv(1)%sm%apply(zone,x,zzero,y,desc_data,trans_,&
& nswps,work_,wv,info)
end if
end associate
else
info = psb_err_from_subroutine_ai_
@ -426,6 +427,7 @@ subroutine mld_zprecaply2_vect(prec,x,y,desc_data,info,trans,work)
! If the original distribution has an overlap we should fix that.
call psb_halo(y,desc_data,info,data=psb_comm_mov_)
if (do_alloc_wrk) call prec%free_wrk(info)
if (present(work)) then
else
@ -459,10 +461,10 @@ subroutine mld_zprecaply1_vect(prec,x,desc_data,info,trans,work)
! Local variables
character :: trans_
type(psb_z_vect_type) :: ww
complex(psb_dpk_), pointer :: work_(:)
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: err_act,iwsz, k, nswps
logical :: do_alloc_wrk
character(len=20) :: name
name='mld_zprecaply'
@ -498,67 +500,72 @@ subroutine mld_zprecaply1_vect(prec,x,desc_data,info,trans,work)
call psb_errpush(info,name)
goto 9999
end if
call psb_geasb(ww,desc_data,info,mold=x%v,scratch=.true.)
if (size(prec%precv) >1) then
!
! Number of levels > 1: apply the multilevel preconditioner
!
call mld_mlprec_aply(zone,prec,x,zzero,ww,desc_data,trans_,work_,info)
if (info == 0) call psb_geaxpby(zone,ww,zzero,x,desc_data,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_zmlprec_aply')
goto 9999
end if
do_alloc_wrk = .not.allocated(prec%precv(1)%wrk)
if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
else if (size(prec%precv) == 1) then
!
! Number of levels = 1: apply the base preconditioner
!
nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post)
if (allocated(prec%precv(1)%sm2a)) then
associate(ww => prec%precv(1)%wrk%vtx, wv => prec%precv(1)%wrk%wv)
if (size(prec%precv) >1) then
!
! This is a kludge for handling the symmetrized GS case.
! Will need some rethinking.
! Number of levels > 1: apply the multilevel preconditioner
!
select case(trans_)
case ('N')
do k=1, nswps
call prec%precv(1)%sm%apply(zone,x,zzero,ww,desc_data,trans_,&
& ione, work_,info)
call prec%precv(1)%sm2a%apply(zone,ww,zzero,x,desc_data,trans_,&
& ione, work_,info)
end do
case('T','C')
do k=1, nswps
call prec%precv(1)%sm2a%apply(zone,x,zzero,ww,desc_data,trans_,&
& ione, work_,info)
call prec%precv(1)%sm%apply(zone,ww,zzero,x,desc_data,trans_,&
& ione, work_,info)
end do
case default
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Invalid trans')
goto 9999
end select
else
call prec%precv(1)%sm%apply(zone,x,zzero,ww,desc_data,trans_,&
& nswps, work_,info)
call mld_mlprec_aply(zone,prec,x,zzero,ww,desc_data,trans_,work_,info)
if (info == 0) call psb_geaxpby(zone,ww,zzero,x,desc_data,info)
end if
else
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_zmlprec_aply')
goto 9999
end if
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
endif
else if (size(prec%precv) == 1) then
!
! Number of levels = 1: apply the base preconditioner
!
nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post)
if (allocated(prec%precv(1)%sm2a)) then
!
! This is a kludge for handling the symmetrized GS case.
! Will need some rethinking.
!
select case(trans_)
case ('N')
do k=1, nswps
call prec%precv(1)%sm%apply(zone,x,zzero,ww,desc_data,trans_,&
& ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(zone,ww,zzero,x,desc_data,trans_,&
& ione, work_,wv,info)
end do
case('T','C')
do k=1, nswps
call prec%precv(1)%sm2a%apply(zone,x,zzero,ww,desc_data,trans_,&
& ione, work_,wv,info)
call prec%precv(1)%sm%apply(zone,ww,zzero,x,desc_data,trans_,&
& ione, work_,wv,info)
end do
case default
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Invalid trans')
goto 9999
end select
if (info == 0) call psb_gefree(ww,desc_data,info)
else
call prec%precv(1)%sm%apply(zone,x,zzero,ww,desc_data,trans_,&
& nswps, work_,wv,info)
if (info == 0) call psb_geaxpby(zone,ww,zzero,x,desc_data,info)
end if
else
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
endif
end associate
! If the original distribution has an overlap we should fix that.
call psb_halo(x,desc_data,info,data=psb_comm_mov_)
if (do_alloc_wrk) call prec%free_wrk(info)
if (present(work)) then
else

4
mlprec/impl/mld_zprecset.F90
Unescape Escape View File

@ -465,7 +465,7 @@ subroutine mld_zprecsetsm(p,val,info,ilev,ilmax,pos)
! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin_, ilmax_
character(len=*), parameter :: name='mld_precseti'
character(len=*), parameter :: name='mld_precsetsm'
info = psb_success_
@ -528,7 +528,7 @@ subroutine mld_zprecsetsv(p,val,info,ilev,ilmax,pos)
! Local variables
integer(psb_ipk_) :: ilev_, nlev_, ilmin_, ilmax_
character(len=*), parameter :: name='mld_precseti'
character(len=*), parameter :: name='mld_precsetsv'
info = psb_success_

163
mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info,init,initu)
& sweeps,work,wv,info,init,initu)
use psb_base_mod
use mld_c_as_smoother, mld_protect_nam => mld_c_as_smoother_apply_vect
implicit none
@ -48,6 +48,7 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu
@ -109,7 +110,7 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
!
! Shortcut: in this case there is nothing else to be done.
!
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -124,88 +125,92 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
! to compute an approximate solution of a linear system.
!
!
call psb_geasb(tx,sm%desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(ty,sm%desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(ww,sm%desc_data,info,mold=x%v,scratch=.true.)
! Need to zero tx because of the apply_restr call.
call tx%zero()
!
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
select case (init_)
case('Z')
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Z')
case('Y')
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y')
case('U')
if (.not.present(initu)) then
if (size(wv) < 3) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in sub_aply Jacobi Sweeps = 1')
& a_err='invalid wv size in smoother_apply')
goto 9999
endif
do i=1, sweeps-1
end if
associate(tx => wv(1), ty => wv(2), ww => wv(3))
! Need to zero tx because of the apply_restr call.
call tx%zero()
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) exit
select case (init_)
case('Z')
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z')
case('Y')
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
end do
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
!
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
!
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in sub_aply Jacobi Sweeps = 1')
goto 9999
endif
do i=1, sweeps-1
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info)
if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
if (info /= psb_success_) exit
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
end do
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
!
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
!
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
end associate
else
info = psb_err_iarg_neg_
@ -219,9 +224,7 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
if (.not.(4*isz <= size(work))) then
deallocate(aux,stat=info)
endif
if (info ==0) call ww%free(info)
if (info ==0) call tx%free(info)
if (info ==0) call ty%free(info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)

7
mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
& trans,sweeps,work,info,init,initu)
& trans,sweeps,work,wv,info,init,initu)
use psb_base_mod
use mld_c_base_smoother_mod, mld_protect_name => mld_c_base_smoother_apply_vect
implicit none
@ -48,10 +48,11 @@ subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu
!
integer(psb_ipk_) :: err_act
character(len=20) :: name='c_base_smoother_apply'
@ -67,7 +68,7 @@ subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
else
if (allocated(sm%sv)) then
call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info,init=init, initu=initu)
call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,wv,info,init=init, initu=initu)
else
info = 1121
endif

126
mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info,init,initu)
& sweeps,work,wv,info,init,initu)
use psb_base_mod
use mld_c_jac_smoother, mld_protect_name => mld_c_jac_smoother_apply_vect
@ -49,10 +49,11 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu
!
integer(psb_ipk_) :: n_row,n_col
type(psb_c_vect_type) :: tx, ty
complex(psb_spk_), pointer :: aux(:)
@ -106,7 +107,7 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nnz_nd_tot==0))) then
! if .not.sv%is_iterative, there's no need to pass init
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,&
@ -121,77 +122,74 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
! to compute an approximate solution of a linear system.
!
!
call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.)
!
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one AXPBY and one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
select case (init_)
case('Z')
call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,info,init='Z')
case('Y')
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y')
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end select
do i=1, sweeps-1
end if
associate(tx => wv(1), ty => wv(2))
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one AXPBY and one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
select case (init_)
case('Z')
call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
case('Y')
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_geaxpby(cone,y,czero,ty,desc_data,info)
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_geaxpby(cone,initu,czero,ty,desc_data,info)
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
if (info /= psb_success_) exit
do i=1, sweeps-1
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
call psb_geaxpby(cone,x,czero,tx,desc_data,info)
call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) exit
if (info /= psb_success_) exit
end do
call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) exit
end do
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
call tx%free(info)
if (info == psb_success_) call ty%free(info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='final cleanup with Jacobi sweeps > 1')
goto 9999
end if
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
end associate
else
info = psb_err_iarg_neg_

163
mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info,init,initu)
& sweeps,work,wv,info,init,initu)
use psb_base_mod
use mld_d_as_smoother, mld_protect_nam => mld_d_as_smoother_apply_vect
implicit none
@ -48,6 +48,7 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
@ -109,7 +110,7 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
!
! Shortcut: in this case there is nothing else to be done.
!
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -124,88 +125,92 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
! to compute an approximate solution of a linear system.
!
!
call psb_geasb(tx,sm%desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(ty,sm%desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(ww,sm%desc_data,info,mold=x%v,scratch=.true.)
! Need to zero tx because of the apply_restr call.
call tx%zero()
!
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
if (info == 0) call psb_geaxpby(done,tx,dzero,ww,sm%desc_data,info)
select case (init_)
case('Z')
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info,init='Z')
case('Y')
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,info,init='Y')
case('U')
if (.not.present(initu)) then
if (size(wv) < 3) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in sub_aply Jacobi Sweeps = 1')
& a_err='invalid wv size in smoother_apply')
goto 9999
endif
do i=1, sweeps-1
end if
associate(tx => wv(1), ty => wv(2), ww => wv(3))
! Need to zero tx because of the apply_restr call.
call tx%zero()
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
if (info == 0) call psb_geaxpby(done,tx,dzero,ww,sm%desc_data,info)
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) exit
select case (init_)
case('Z')
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z')
case('Y')
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
end do
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
!
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
!
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in sub_aply Jacobi Sweeps = 1')
goto 9999
endif
do i=1, sweeps-1
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
if (info == 0) call psb_geaxpby(done,tx,dzero,ww,sm%desc_data,info)
if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
if (info /= psb_success_) exit
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
end do
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
!
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
!
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
end associate
else
info = psb_err_iarg_neg_
@ -219,9 +224,7 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
if (.not.(4*isz <= size(work))) then
deallocate(aux,stat=info)
endif
if (info ==0) call ww%free(info)
if (info ==0) call tx%free(info)
if (info ==0) call ty%free(info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)

7
mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
& trans,sweeps,work,info,init,initu)
& trans,sweeps,work,wv,info,init,initu)
use psb_base_mod
use mld_d_base_smoother_mod, mld_protect_name => mld_d_base_smoother_apply_vect
implicit none
@ -48,10 +48,11 @@ subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
!
integer(psb_ipk_) :: err_act
character(len=20) :: name='d_base_smoother_apply'
@ -67,7 +68,7 @@ subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
else
if (allocated(sm%sv)) then
call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info,init=init, initu=initu)
call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,wv,info,init=init, initu=initu)
else
info = 1121
endif

126
mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info,init,initu)
& sweeps,work,wv,info,init,initu)
use psb_base_mod
use mld_d_jac_smoother, mld_protect_name => mld_d_jac_smoother_apply_vect
@ -49,10 +49,11 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
!
integer(psb_ipk_) :: n_row,n_col
type(psb_d_vect_type) :: tx, ty
real(psb_dpk_), pointer :: aux(:)
@ -106,7 +107,7 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nnz_nd_tot==0))) then
! if .not.sv%is_iterative, there's no need to pass init
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,&
@ -121,77 +122,74 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
! to compute an approximate solution of a linear system.
!
!
call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.)
!
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one AXPBY and one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
select case (init_)
case('Z')
call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,info,init='Z')
case('Y')
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y')
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end select
do i=1, sweeps-1
end if
associate(tx => wv(1), ty => wv(2))
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one AXPBY and one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
select case (init_)
case('Z')
call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
case('Y')
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_geaxpby(done,y,dzero,ty,desc_data,info)
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_geaxpby(done,initu,dzero,ty,desc_data,info)
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
if (info /= psb_success_) exit
do i=1, sweeps-1
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
call psb_geaxpby(done,x,dzero,tx,desc_data,info)
call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) exit
if (info /= psb_success_) exit
end do
call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) exit
end do
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
call tx%free(info)
if (info == psb_success_) call ty%free(info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='final cleanup with Jacobi sweeps > 1')
goto 9999
end if
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
end associate
else
info = psb_err_iarg_neg_

163
mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info,init,initu)
& sweeps,work,wv,info,init,initu)
use psb_base_mod
use mld_s_as_smoother, mld_protect_nam => mld_s_as_smoother_apply_vect
implicit none
@ -48,6 +48,7 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
@ -109,7 +110,7 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
!
! Shortcut: in this case there is nothing else to be done.
!
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -124,88 +125,92 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
! to compute an approximate solution of a linear system.
!
!
call psb_geasb(tx,sm%desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(ty,sm%desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(ww,sm%desc_data,info,mold=x%v,scratch=.true.)
! Need to zero tx because of the apply_restr call.
call tx%zero()
!
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
if (info == 0) call psb_geaxpby(sone,tx,szero,ww,sm%desc_data,info)
select case (init_)
case('Z')
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info,init='Z')
case('Y')
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,info,init='Y')
case('U')
if (.not.present(initu)) then
if (size(wv) < 3) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in sub_aply Jacobi Sweeps = 1')
& a_err='invalid wv size in smoother_apply')
goto 9999
endif
do i=1, sweeps-1
end if
associate(tx => wv(1), ty => wv(2), ww => wv(3))
! Need to zero tx because of the apply_restr call.
call tx%zero()
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
if (info == 0) call psb_geaxpby(sone,tx,szero,ww,sm%desc_data,info)
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) exit
select case (init_)
case('Z')
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z')
case('Y')
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
end do
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
!
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
!
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in sub_aply Jacobi Sweeps = 1')
goto 9999
endif
do i=1, sweeps-1
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
if (info == 0) call psb_geaxpby(sone,tx,szero,ww,sm%desc_data,info)
if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
if (info /= psb_success_) exit
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
end do
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
!
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
!
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
end associate
else
info = psb_err_iarg_neg_
@ -219,9 +224,7 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
if (.not.(4*isz <= size(work))) then
deallocate(aux,stat=info)
endif
if (info ==0) call ww%free(info)
if (info ==0) call tx%free(info)
if (info ==0) call ty%free(info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)

7
mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
& trans,sweeps,work,info,init,initu)
& trans,sweeps,work,wv,info,init,initu)
use psb_base_mod
use mld_s_base_smoother_mod, mld_protect_name => mld_s_base_smoother_apply_vect
implicit none
@ -48,10 +48,11 @@ subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
!
integer(psb_ipk_) :: err_act
character(len=20) :: name='s_base_smoother_apply'
@ -67,7 +68,7 @@ subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
else
if (allocated(sm%sv)) then
call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info,init=init, initu=initu)
call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,wv,info,init=init, initu=initu)
else
info = 1121
endif

126
mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info,init,initu)
& sweeps,work,wv,info,init,initu)
use psb_base_mod
use mld_s_jac_smoother, mld_protect_name => mld_s_jac_smoother_apply_vect
@ -49,10 +49,11 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
!
integer(psb_ipk_) :: n_row,n_col
type(psb_s_vect_type) :: tx, ty
real(psb_spk_), pointer :: aux(:)
@ -106,7 +107,7 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nnz_nd_tot==0))) then
! if .not.sv%is_iterative, there's no need to pass init
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,&
@ -121,77 +122,74 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
! to compute an approximate solution of a linear system.
!
!
call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.)
!
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one AXPBY and one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
select case (init_)
case('Z')
call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,info,init='Z')
case('Y')
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y')
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end select
do i=1, sweeps-1
end if
associate(tx => wv(1), ty => wv(2))
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one AXPBY and one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
select case (init_)
case('Z')
call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
case('Y')
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_geaxpby(sone,y,szero,ty,desc_data,info)
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_geaxpby(sone,initu,szero,ty,desc_data,info)
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
if (info /= psb_success_) exit
do i=1, sweeps-1
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
call psb_geaxpby(sone,x,szero,tx,desc_data,info)
call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) exit
if (info /= psb_success_) exit
end do
call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) exit
end do
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
call tx%free(info)
if (info == psb_success_) call ty%free(info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='final cleanup with Jacobi sweeps > 1')
goto 9999
end if
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
end associate
else
info = psb_err_iarg_neg_

163
mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info,init,initu)
& sweeps,work,wv,info,init,initu)
use psb_base_mod
use mld_z_as_smoother, mld_protect_nam => mld_z_as_smoother_apply_vect
implicit none
@ -48,6 +48,7 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu
@ -109,7 +110,7 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
!
! Shortcut: in this case there is nothing else to be done.
!
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -124,88 +125,92 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
! to compute an approximate solution of a linear system.
!
!
call psb_geasb(tx,sm%desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(ty,sm%desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(ww,sm%desc_data,info,mold=x%v,scratch=.true.)
! Need to zero tx because of the apply_restr call.
call tx%zero()
!
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
if (info == 0) call psb_geaxpby(zone,tx,zzero,ww,sm%desc_data,info)
select case (init_)
case('Z')
call sm%sv%apply(zone,ww,zzero,ty,sm%desc_data,trans_,aux,info,init='Z')
case('Y')
call psb_geaxpby(zone,y,zzero,ty,desc_data,info)
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
if (info == 0) call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
call sm%sv%apply(zone,ww,zzero,ty,desc_data,trans_,aux,info,init='Y')
case('U')
if (.not.present(initu)) then
if (size(wv) < 3) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(zone,initu,zzero,ty,desc_data,info)
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
if (info == 0) call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
call sm%sv%apply(zone,ww,zzero,ty,desc_data,trans_,aux,info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in sub_aply Jacobi Sweeps = 1')
& a_err='invalid wv size in smoother_apply')
goto 9999
endif
do i=1, sweeps-1
end if
associate(tx => wv(1), ty => wv(2), ww => wv(3))
! Need to zero tx because of the apply_restr call.
call tx%zero()
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
if (info == 0) call sm%apply_restr(tx,trans_,aux,info)
if (info == 0) call psb_geaxpby(zone,tx,zzero,ww,sm%desc_data,info)
if (info == 0) call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(zone,ww,zzero,ty,sm%desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) exit
select case (init_)
case('Z')
call sm%sv%apply(zone,ww,zzero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z')
case('Y')
call psb_geaxpby(zone,y,zzero,ty,desc_data,info)
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
if (info == 0) call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
call sm%sv%apply(zone,ww,zzero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(zone,initu,zzero,ty,desc_data,info)
if (info == 0) call sm%apply_restr(ty,trans_,aux,info)
if (info == 0) call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
call sm%sv%apply(zone,ww,zzero,ty,desc_data,trans_,aux,wv(4:),info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
end do
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
!
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
!
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in sub_aply Jacobi Sweeps = 1')
goto 9999
endif
do i=1, sweeps-1
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
if (info == 0) call psb_geaxpby(zone,tx,zzero,ww,sm%desc_data,info)
if (info == 0) call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,&
& work=aux,trans=trans_)
if (info /= psb_success_) exit
call sm%sv%apply(zone,ww,zzero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y')
if (info /= psb_success_) exit
if (info == 0) call sm%apply_prol(ty,trans_,aux,info)
end do
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
!
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
!
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
end associate
else
info = psb_err_iarg_neg_
@ -219,9 +224,7 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
if (.not.(4*isz <= size(work))) then
deallocate(aux,stat=info)
endif
if (info ==0) call ww%free(info)
if (info ==0) call tx%free(info)
if (info ==0) call ty%free(info)
if (info /= 0) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)

7
mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
& trans,sweeps,work,info,init,initu)
& trans,sweeps,work,wv,info,init,initu)
use psb_base_mod
use mld_z_base_smoother_mod, mld_protect_name => mld_z_base_smoother_apply_vect
implicit none
@ -48,10 +48,11 @@ subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu
!
integer(psb_ipk_) :: err_act
character(len=20) :: name='z_base_smoother_apply'
@ -67,7 +68,7 @@ subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
else
if (allocated(sm%sv)) then
call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info,init=init, initu=initu)
call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,wv,info,init=init, initu=initu)
else
info = 1121
endif

126
mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info,init,initu)
& sweeps,work,wv,info,init,initu)
use psb_base_mod
use mld_z_jac_smoother, mld_protect_name => mld_z_jac_smoother_apply_vect
@ -49,10 +49,11 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu
!
integer(psb_ipk_) :: n_row,n_col
type(psb_z_vect_type) :: tx, ty
complex(psb_dpk_), pointer :: aux(:)
@ -106,7 +107,7 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nnz_nd_tot==0))) then
! if .not.sv%is_iterative, there's no need to pass init
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info)
call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,&
@ -121,77 +122,74 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
! to compute an approximate solution of a linear system.
!
!
call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.)
!
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one AXPBY and one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
select case (init_)
case('Z')
call sm%sv%apply(zone,x,zzero,ty,desc_data,trans_,aux,info,init='Z')
case('Y')
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_geaxpby(zone,y,zzero,ty,desc_data,info)
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y')
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_geaxpby(zone,initu,zzero,ty,desc_data,info)
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end select
do i=1, sweeps-1
end if
associate(tx => wv(1), ty => wv(2))
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
! Unroll the first iteration and fold it inside SELECT CASE
! this will save one AXPBY and one SPMM when INIT=Z, and will be
! significant when sweeps=1 (a common case)
!
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
select case (init_)
case('Z')
call sm%sv%apply(zone,x,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z')
case('Y')
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_geaxpby(zone,y,zzero,ty,desc_data,info)
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_geaxpby(zone,initu,zzero,ty,desc_data,info)
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end select
if (info /= psb_success_) exit
do i=1, sweeps-1
!
! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the
! block diagonal part and the remaining part of the local matrix
! and Y(j) is the approximate solution at sweep j.
!
call psb_geaxpby(zone,x,zzero,tx,desc_data,info)
call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_)
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y')
if (info /= psb_success_) exit
if (info /= psb_success_) exit
end do
call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y')
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
if (info /= psb_success_) exit
end do
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
call tx%free(info)
if (info == psb_success_) call ty%free(info)
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='final cleanup with Jacobi sweeps > 1')
goto 9999
end if
if (info /= psb_success_) then
info=psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
end associate
else
info = psb_err_iarg_neg_

3
mlprec/impl/solver/mld_c_base_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_c_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_c_base_solver_mod, mld_protect_name => mld_c_base_solver_apply_vect
@ -48,6 +48,7 @@ subroutine mld_c_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu

136
mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_c_gs_solver, mld_protect_name => mld_c_bwgs_solver_apply_vect
@ -48,12 +48,12 @@ subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu
integer(psb_ipk_) :: n_row,n_col, itx
type(psb_c_vect_type) :: wv, xit
complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
complex(psb_spk_), allocatable :: temp(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
@ -120,84 +120,76 @@ subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
goto 9999
end if
call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.)
select case (init_)
case('Z')
call xit%zero()
case('Y')
call psb_geaxpby(cone,y,czero,xit,desc_data,info)
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(cone,initu,czero,xit,desc_data,info)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size')
goto 9999
end select
select case(trans_)
case('N')
if (sv%eps <=szero) then
!
! Fixed number of iterations
!
!
do itx=1,sv%sweeps
call psb_geaxpby(cone,x,czero,wv,desc_data,info)
! Update with L. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-cone,sv%l,xit,cone,wv,desc_data,info,doswap=.false.)
call psb_spsm(cone,sv%u,wv,czero,xit,desc_data,info)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
end if
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
associate(tw => wv(1), xit => wv(2))
select case (init_)
case('Z')
call xit%zero()
case('Y')
call psb_geaxpby(cone,y,czero,xit,desc_data,info)
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(cone,initu,czero,xit,desc_data,info)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end if
!!$ case('T')
!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,&
!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ case('C')
!!$
!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ call wv1%mlt(cone,sv%dv,wv,czero,info,conjgx=trans_)
!!$
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
end select
select case(trans_)
case('N')
if (sv%eps <=szero) then
!
! Fixed number of iterations
!
!
do itx=1,sv%sweeps
call psb_geaxpby(cone,x,czero,tw,desc_data,info)
! Update with L. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-cone,sv%l,xit,cone,tw,desc_data,info,doswap=.false.)
call psb_spsm(cone,sv%u,tw,czero,xit,desc_data,info)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
if (info /= psb_success_) then
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
call wv%free(info)
call xit%free(info)
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
end associate
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else

3
mlprec/impl/solver/mld_c_diag_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_c_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_c_diag_solver, mld_protect_name => mld_c_diag_solver_apply_vect
@ -48,6 +48,7 @@ subroutine mld_c_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu

136
mlprec/impl/solver/mld_c_gs_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_c_gs_solver, mld_protect_name => mld_c_gs_solver_apply_vect
@ -48,12 +48,12 @@ subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu
integer(psb_ipk_) :: n_row,n_col, itx
type(psb_c_vect_type) :: wv, xit
complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
complex(psb_spk_), allocatable :: temp(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
@ -120,84 +120,76 @@ subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
goto 9999
end if
call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.)
select case (init_)
case('Z')
call xit%zero()
case('Y')
call psb_geaxpby(cone,y,czero,xit,desc_data,info)
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(cone,initu,czero,xit,desc_data,info)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size')
goto 9999
end select
select case(trans_)
case('N')
if (sv%eps <=szero) then
!
! Fixed number of iterations
!
!
do itx=1,sv%sweeps
call psb_geaxpby(cone,x,czero,wv,desc_data,info)
! Update with U. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-cone,sv%u,xit,cone,wv,desc_data,info,doswap=.false.)
call psb_spsm(cone,sv%l,wv,czero,xit,desc_data,info)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
end if
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
associate(tw => wv(1), xit => wv(2))
select case (init_)
case('Z')
call xit%zero()
case('Y')
call psb_geaxpby(cone,y,czero,xit,desc_data,info)
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(cone,initu,czero,xit,desc_data,info)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end if
!!$ case('T')
!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,&
!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ case('C')
!!$
!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ call wv1%mlt(cone,sv%dv,wv,czero,info,conjgx=trans_)
!!$
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
end select
select case(trans_)
case('N')
if (sv%eps <=szero) then
!
! Fixed number of iterations
!
!
do itx=1,sv%sweeps
call psb_geaxpby(cone,x,czero,tw,desc_data,info)
! Update with U. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-cone,sv%u,xit,cone,tw,desc_data,info,doswap=.false.)
call psb_spsm(cone,sv%l,tw,czero,xit,desc_data,info)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
if (info /= psb_success_) then
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
call wv%free(info)
call xit%free(info)
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
end associate
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else

3
mlprec/impl/solver/mld_c_id_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_c_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_c_id_solver, mld_protect_name => mld_c_id_solver_apply_vect
@ -48,6 +48,7 @@ subroutine mld_c_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu

75
mlprec/impl/solver/mld_c_ilu_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_c_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_c_ilu_solver, mld_protect_name => mld_c_ilu_solver_apply_vect
@ -48,12 +48,13 @@ subroutine mld_c_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu
integer(psb_ipk_) :: n_row,n_col
type(psb_c_vect_type) :: wv, wv1
type(psb_c_vect_type) :: tw, tw1
complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
@ -124,48 +125,56 @@ subroutine mld_c_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
goto 9999
end if
call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(wv1,desc_data,info,mold=x%v,scratch=.true.)
select case(trans_)
case('N')
call psb_spsm(cone,sv%l,x,czero,wv,desc_data,info,&
& trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size')
goto 9999
end if
if (info == psb_success_) call psb_spsm(alpha,sv%u,wv,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_, work=aux)
associate(tw => wv(1), tw1 => wv(2))
case('T')
call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,&
& trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
select case(trans_)
case('N')
call psb_spsm(cone,sv%l,x,czero,tw,desc_data,info,&
& trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
case('C')
if (info == psb_success_) call psb_spsm(alpha,sv%u,tw,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_, work=aux)
call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
case('T')
call psb_spsm(cone,sv%u,x,czero,tw,desc_data,info,&
& trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
if (info == psb_success_) call psb_spsm(alpha,sv%l,tw,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
call wv1%mlt(cone,sv%dv,wv,czero,info,conjgx=trans_)
case('C')
if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
call psb_spsm(cone,sv%u,x,czero,tw,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Invalid TRANS in ILU subsolve')
goto 9999
end select
call tw1%mlt(cone,sv%dv,tw,czero,info,conjgx=trans_)
if (info == psb_success_) call psb_spsm(alpha,sv%l,tw1,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
if (info /= psb_success_) then
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Invalid TRANS in ILU subsolve')
goto 9999
end select
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
call wv%free(info)
call wv1%free(info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
end associate
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else

5
mlprec/impl/solver/mld_c_mumps_solver_apply_vect.F90
Unescape Escape View File

@ -40,7 +40,7 @@
!
!
subroutine c_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_c_mumps_solver
implicit none
@ -49,8 +49,9 @@ subroutine c_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
type(psb_c_vect_type),intent(inout) :: x
type(psb_c_vect_type),intent(inout) :: y
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu

3
mlprec/impl/solver/mld_d_base_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_d_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_d_base_solver_mod, mld_protect_name => mld_d_base_solver_apply_vect
@ -48,6 +48,7 @@ subroutine mld_d_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu

136
mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_d_gs_solver, mld_protect_name => mld_d_bwgs_solver_apply_vect
@ -48,12 +48,12 @@ subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
integer(psb_ipk_) :: n_row,n_col, itx
type(psb_d_vect_type) :: wv, xit
real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
real(psb_dpk_), allocatable :: temp(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
@ -120,84 +120,76 @@ subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
goto 9999
end if
call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.)
select case (init_)
case('Z')
call xit%zero()
case('Y')
call psb_geaxpby(done,y,dzero,xit,desc_data,info)
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(done,initu,dzero,xit,desc_data,info)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size')
goto 9999
end select
select case(trans_)
case('N')
if (sv%eps <=dzero) then
!
! Fixed number of iterations
!
!
do itx=1,sv%sweeps
call psb_geaxpby(done,x,dzero,wv,desc_data,info)
! Update with L. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-done,sv%l,xit,done,wv,desc_data,info,doswap=.false.)
call psb_spsm(done,sv%u,wv,dzero,xit,desc_data,info)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
end if
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
associate(tw => wv(1), xit => wv(2))
select case (init_)
case('Z')
call xit%zero()
case('Y')
call psb_geaxpby(done,y,dzero,xit,desc_data,info)
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(done,initu,dzero,xit,desc_data,info)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end if
!!$ case('T')
!!$ call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,&
!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ case('C')
!!$
!!$ call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ call wv1%mlt(done,sv%dv,wv,dzero,info,conjgx=trans_)
!!$
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
end select
select case(trans_)
case('N')
if (sv%eps <=dzero) then
!
! Fixed number of iterations
!
!
do itx=1,sv%sweeps
call psb_geaxpby(done,x,dzero,tw,desc_data,info)
! Update with L. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-done,sv%l,xit,done,tw,desc_data,info,doswap=.false.)
call psb_spsm(done,sv%u,tw,dzero,xit,desc_data,info)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
if (info /= psb_success_) then
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
call wv%free(info)
call xit%free(info)
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
end associate
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else

3
mlprec/impl/solver/mld_d_diag_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_d_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_d_diag_solver, mld_protect_name => mld_d_diag_solver_apply_vect
@ -48,6 +48,7 @@ subroutine mld_d_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu

136
mlprec/impl/solver/mld_d_gs_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_d_gs_solver, mld_protect_name => mld_d_gs_solver_apply_vect
@ -48,12 +48,12 @@ subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
integer(psb_ipk_) :: n_row,n_col, itx
type(psb_d_vect_type) :: wv, xit
real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
real(psb_dpk_), allocatable :: temp(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
@ -120,84 +120,76 @@ subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
goto 9999
end if
call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.)
select case (init_)
case('Z')
call xit%zero()
case('Y')
call psb_geaxpby(done,y,dzero,xit,desc_data,info)
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(done,initu,dzero,xit,desc_data,info)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size')
goto 9999
end select
select case(trans_)
case('N')
if (sv%eps <=dzero) then
!
! Fixed number of iterations
!
!
do itx=1,sv%sweeps
call psb_geaxpby(done,x,dzero,wv,desc_data,info)
! Update with U. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-done,sv%u,xit,done,wv,desc_data,info,doswap=.false.)
call psb_spsm(done,sv%l,wv,dzero,xit,desc_data,info)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
end if
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
associate(tw => wv(1), xit => wv(2))
select case (init_)
case('Z')
call xit%zero()
case('Y')
call psb_geaxpby(done,y,dzero,xit,desc_data,info)
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(done,initu,dzero,xit,desc_data,info)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end if
!!$ case('T')
!!$ call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,&
!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ case('C')
!!$
!!$ call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ call wv1%mlt(done,sv%dv,wv,dzero,info,conjgx=trans_)
!!$
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
end select
select case(trans_)
case('N')
if (sv%eps <=dzero) then
!
! Fixed number of iterations
!
!
do itx=1,sv%sweeps
call psb_geaxpby(done,x,dzero,tw,desc_data,info)
! Update with U. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-done,sv%u,xit,done,tw,desc_data,info,doswap=.false.)
call psb_spsm(done,sv%l,tw,dzero,xit,desc_data,info)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
if (info /= psb_success_) then
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
call wv%free(info)
call xit%free(info)
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
end associate
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else

3
mlprec/impl/solver/mld_d_id_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_d_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_d_id_solver, mld_protect_name => mld_d_id_solver_apply_vect
@ -48,6 +48,7 @@ subroutine mld_d_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu

75
mlprec/impl/solver/mld_d_ilu_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_d_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_d_ilu_solver, mld_protect_name => mld_d_ilu_solver_apply_vect
@ -48,12 +48,13 @@ subroutine mld_d_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
integer(psb_ipk_) :: n_row,n_col
type(psb_d_vect_type) :: wv, wv1
type(psb_d_vect_type) :: tw, tw1
real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
@ -124,48 +125,56 @@ subroutine mld_d_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
goto 9999
end if
call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(wv1,desc_data,info,mold=x%v,scratch=.true.)
select case(trans_)
case('N')
call psb_spsm(done,sv%l,x,dzero,wv,desc_data,info,&
& trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size')
goto 9999
end if
if (info == psb_success_) call psb_spsm(alpha,sv%u,wv,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_, work=aux)
associate(tw => wv(1), tw1 => wv(2))
case('T')
call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,&
& trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
select case(trans_)
case('N')
call psb_spsm(done,sv%l,x,dzero,tw,desc_data,info,&
& trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
case('C')
if (info == psb_success_) call psb_spsm(alpha,sv%u,tw,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_, work=aux)
call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
case('T')
call psb_spsm(done,sv%u,x,dzero,tw,desc_data,info,&
& trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
if (info == psb_success_) call psb_spsm(alpha,sv%l,tw,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
call wv1%mlt(done,sv%dv,wv,dzero,info,conjgx=trans_)
case('C')
if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
call psb_spsm(done,sv%u,x,dzero,tw,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Invalid TRANS in ILU subsolve')
goto 9999
end select
call tw1%mlt(done,sv%dv,tw,dzero,info,conjgx=trans_)
if (info == psb_success_) call psb_spsm(alpha,sv%l,tw1,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
if (info /= psb_success_) then
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Invalid TRANS in ILU subsolve')
goto 9999
end select
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
call wv%free(info)
call wv1%free(info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
end associate
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else

5
mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90
Unescape Escape View File

@ -40,7 +40,7 @@
!
!
subroutine d_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_d_mumps_solver
implicit none
@ -49,8 +49,9 @@ subroutine d_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
type(psb_d_vect_type),intent(inout) :: x
type(psb_d_vect_type),intent(inout) :: y
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu

3
mlprec/impl/solver/mld_s_base_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_s_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_s_base_solver_mod, mld_protect_name => mld_s_base_solver_apply_vect
@ -48,6 +48,7 @@ subroutine mld_s_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu

136
mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_s_gs_solver, mld_protect_name => mld_s_bwgs_solver_apply_vect
@ -48,12 +48,12 @@ subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
integer(psb_ipk_) :: n_row,n_col, itx
type(psb_s_vect_type) :: wv, xit
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
real(psb_spk_), allocatable :: temp(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
@ -120,84 +120,76 @@ subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
goto 9999
end if
call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.)
select case (init_)
case('Z')
call xit%zero()
case('Y')
call psb_geaxpby(sone,y,szero,xit,desc_data,info)
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(sone,initu,szero,xit,desc_data,info)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size')
goto 9999
end select
select case(trans_)
case('N')
if (sv%eps <=szero) then
!
! Fixed number of iterations
!
!
do itx=1,sv%sweeps
call psb_geaxpby(sone,x,szero,wv,desc_data,info)
! Update with L. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-sone,sv%l,xit,sone,wv,desc_data,info,doswap=.false.)
call psb_spsm(sone,sv%u,wv,szero,xit,desc_data,info)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
end if
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
associate(tw => wv(1), xit => wv(2))
select case (init_)
case('Z')
call xit%zero()
case('Y')
call psb_geaxpby(sone,y,szero,xit,desc_data,info)
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(sone,initu,szero,xit,desc_data,info)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end if
!!$ case('T')
!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,&
!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ case('C')
!!$
!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ call wv1%mlt(sone,sv%dv,wv,szero,info,conjgx=trans_)
!!$
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
end select
select case(trans_)
case('N')
if (sv%eps <=szero) then
!
! Fixed number of iterations
!
!
do itx=1,sv%sweeps
call psb_geaxpby(sone,x,szero,tw,desc_data,info)
! Update with L. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-sone,sv%l,xit,sone,tw,desc_data,info,doswap=.false.)
call psb_spsm(sone,sv%u,tw,szero,xit,desc_data,info)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
if (info /= psb_success_) then
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
call wv%free(info)
call xit%free(info)
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
end associate
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else

3
mlprec/impl/solver/mld_s_diag_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_s_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_s_diag_solver, mld_protect_name => mld_s_diag_solver_apply_vect
@ -48,6 +48,7 @@ subroutine mld_s_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu

136
mlprec/impl/solver/mld_s_gs_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_s_gs_solver, mld_protect_name => mld_s_gs_solver_apply_vect
@ -48,12 +48,12 @@ subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
integer(psb_ipk_) :: n_row,n_col, itx
type(psb_s_vect_type) :: wv, xit
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
real(psb_spk_), allocatable :: temp(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
@ -120,84 +120,76 @@ subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
goto 9999
end if
call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.)
select case (init_)
case('Z')
call xit%zero()
case('Y')
call psb_geaxpby(sone,y,szero,xit,desc_data,info)
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(sone,initu,szero,xit,desc_data,info)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size')
goto 9999
end select
select case(trans_)
case('N')
if (sv%eps <=szero) then
!
! Fixed number of iterations
!
!
do itx=1,sv%sweeps
call psb_geaxpby(sone,x,szero,wv,desc_data,info)
! Update with U. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-sone,sv%u,xit,sone,wv,desc_data,info,doswap=.false.)
call psb_spsm(sone,sv%l,wv,szero,xit,desc_data,info)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
end if
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
associate(tw => wv(1), xit => wv(2))
select case (init_)
case('Z')
call xit%zero()
case('Y')
call psb_geaxpby(sone,y,szero,xit,desc_data,info)
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(sone,initu,szero,xit,desc_data,info)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end if
!!$ case('T')
!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,&
!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ case('C')
!!$
!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ call wv1%mlt(sone,sv%dv,wv,szero,info,conjgx=trans_)
!!$
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
end select
select case(trans_)
case('N')
if (sv%eps <=szero) then
!
! Fixed number of iterations
!
!
do itx=1,sv%sweeps
call psb_geaxpby(sone,x,szero,tw,desc_data,info)
! Update with U. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-sone,sv%u,xit,sone,tw,desc_data,info,doswap=.false.)
call psb_spsm(sone,sv%l,tw,szero,xit,desc_data,info)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
if (info /= psb_success_) then
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
call wv%free(info)
call xit%free(info)
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
end associate
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else

3
mlprec/impl/solver/mld_s_id_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_s_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_s_id_solver, mld_protect_name => mld_s_id_solver_apply_vect
@ -48,6 +48,7 @@ subroutine mld_s_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu

75
mlprec/impl/solver/mld_s_ilu_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_s_ilu_solver, mld_protect_name => mld_s_ilu_solver_apply_vect
@ -48,12 +48,13 @@ subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
integer(psb_ipk_) :: n_row,n_col
type(psb_s_vect_type) :: wv, wv1
type(psb_s_vect_type) :: tw, tw1
real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
@ -124,48 +125,56 @@ subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
goto 9999
end if
call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(wv1,desc_data,info,mold=x%v,scratch=.true.)
select case(trans_)
case('N')
call psb_spsm(sone,sv%l,x,szero,wv,desc_data,info,&
& trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size')
goto 9999
end if
if (info == psb_success_) call psb_spsm(alpha,sv%u,wv,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_, work=aux)
associate(tw => wv(1), tw1 => wv(2))
case('T')
call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,&
& trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
select case(trans_)
case('N')
call psb_spsm(sone,sv%l,x,szero,tw,desc_data,info,&
& trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
case('C')
if (info == psb_success_) call psb_spsm(alpha,sv%u,tw,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_, work=aux)
call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
case('T')
call psb_spsm(sone,sv%u,x,szero,tw,desc_data,info,&
& trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
if (info == psb_success_) call psb_spsm(alpha,sv%l,tw,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
call wv1%mlt(sone,sv%dv,wv,szero,info,conjgx=trans_)
case('C')
if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
call psb_spsm(sone,sv%u,x,szero,tw,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Invalid TRANS in ILU subsolve')
goto 9999
end select
call tw1%mlt(sone,sv%dv,tw,szero,info,conjgx=trans_)
if (info == psb_success_) call psb_spsm(alpha,sv%l,tw1,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
if (info /= psb_success_) then
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Invalid TRANS in ILU subsolve')
goto 9999
end select
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
call wv%free(info)
call wv1%free(info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
end associate
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else

5
mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90
Unescape Escape View File

@ -40,7 +40,7 @@
!
!
subroutine s_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_s_mumps_solver
implicit none
@ -49,8 +49,9 @@ subroutine s_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
type(psb_s_vect_type),intent(inout) :: x
type(psb_s_vect_type),intent(inout) :: y
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu

3
mlprec/impl/solver/mld_z_base_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_z_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_z_base_solver_mod, mld_protect_name => mld_z_base_solver_apply_vect
@ -48,6 +48,7 @@ subroutine mld_z_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu

136
mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_z_gs_solver, mld_protect_name => mld_z_bwgs_solver_apply_vect
@ -48,12 +48,12 @@ subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu
integer(psb_ipk_) :: n_row,n_col, itx
type(psb_z_vect_type) :: wv, xit
complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
complex(psb_dpk_), allocatable :: temp(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
@ -120,84 +120,76 @@ subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
goto 9999
end if
call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.)
select case (init_)
case('Z')
call xit%zero()
case('Y')
call psb_geaxpby(zone,y,zzero,xit,desc_data,info)
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(zone,initu,zzero,xit,desc_data,info)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size')
goto 9999
end select
select case(trans_)
case('N')
if (sv%eps <=dzero) then
!
! Fixed number of iterations
!
!
do itx=1,sv%sweeps
call psb_geaxpby(zone,x,zzero,wv,desc_data,info)
! Update with L. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-zone,sv%l,xit,zone,wv,desc_data,info,doswap=.false.)
call psb_spsm(zone,sv%u,wv,zzero,xit,desc_data,info)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
end if
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
associate(tw => wv(1), xit => wv(2))
select case (init_)
case('Z')
call xit%zero()
case('Y')
call psb_geaxpby(zone,y,zzero,xit,desc_data,info)
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(zone,initu,zzero,xit,desc_data,info)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end if
!!$ case('T')
!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,&
!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ case('C')
!!$
!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ call wv1%mlt(zone,sv%dv,wv,zzero,info,conjgx=trans_)
!!$
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
end select
select case(trans_)
case('N')
if (sv%eps <=dzero) then
!
! Fixed number of iterations
!
!
do itx=1,sv%sweeps
call psb_geaxpby(zone,x,zzero,tw,desc_data,info)
! Update with L. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-zone,sv%l,xit,zone,tw,desc_data,info,doswap=.false.)
call psb_spsm(zone,sv%u,tw,zzero,xit,desc_data,info)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
if (info /= psb_success_) then
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
call wv%free(info)
call xit%free(info)
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
end associate
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else

3
mlprec/impl/solver/mld_z_diag_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_z_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_z_diag_solver, mld_protect_name => mld_z_diag_solver_apply_vect
@ -48,6 +48,7 @@ subroutine mld_z_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu

136
mlprec/impl/solver/mld_z_gs_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_z_gs_solver, mld_protect_name => mld_z_gs_solver_apply_vect
@ -48,12 +48,12 @@ subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu
integer(psb_ipk_) :: n_row,n_col, itx
type(psb_z_vect_type) :: wv, xit
complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
complex(psb_dpk_), allocatable :: temp(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
@ -120,84 +120,76 @@ subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
goto 9999
end if
call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.)
select case (init_)
case('Z')
call xit%zero()
case('Y')
call psb_geaxpby(zone,y,zzero,xit,desc_data,info)
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(zone,initu,zzero,xit,desc_data,info)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size')
goto 9999
end select
select case(trans_)
case('N')
if (sv%eps <=dzero) then
!
! Fixed number of iterations
!
!
do itx=1,sv%sweeps
call psb_geaxpby(zone,x,zzero,wv,desc_data,info)
! Update with U. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-zone,sv%u,xit,zone,wv,desc_data,info,doswap=.false.)
call psb_spsm(zone,sv%l,wv,zzero,xit,desc_data,info)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
end if
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
associate(tw => wv(1), xit => wv(2))
select case (init_)
case('Z')
call xit%zero()
case('Y')
call psb_geaxpby(zone,y,zzero,xit,desc_data,info)
case('U')
if (.not.present(initu)) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='missing initu to smoother_apply')
goto 9999
end if
call psb_geaxpby(zone,initu,zzero,xit,desc_data,info)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='wrong init to smoother_apply')
goto 9999
end if
!!$ case('T')
!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,&
!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ case('C')
!!$
!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
!!$
!!$ call wv1%mlt(zone,sv%dv,wv,zzero,info,conjgx=trans_)
!!$
!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
end select
select case(trans_)
case('N')
if (sv%eps <=dzero) then
!
! Fixed number of iterations
!
!
do itx=1,sv%sweeps
call psb_geaxpby(zone,x,zzero,tw,desc_data,info)
! Update with U. The off-diagonal block is taken care
! from the Jacobi smoother, hence this is purely local.
call psb_spmm(-zone,sv%u,xit,zone,tw,desc_data,info,doswap=.false.)
call psb_spsm(zone,sv%l,tw,zzero,xit,desc_data,info)
end do
call psb_geaxpby(alpha,xit,beta,y,desc_data,info)
else
!
! Iterations to convergence, not implemented right now.
!
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve')
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
& a_err='Invalid TRANS in GS subsolve')
goto 9999
end select
if (info /= psb_success_) then
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
call wv%free(info)
call xit%free(info)
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
end associate
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else

3
mlprec/impl/solver/mld_z_id_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_z_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_z_id_solver, mld_protect_name => mld_z_id_solver_apply_vect
@ -48,6 +48,7 @@ subroutine mld_z_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu

75
mlprec/impl/solver/mld_z_ilu_solver_apply_vect.f90
Unescape Escape View File

@ -36,7 +36,7 @@
!
!
subroutine mld_z_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_z_ilu_solver, mld_protect_name => mld_z_ilu_solver_apply_vect
@ -48,12 +48,13 @@ subroutine mld_z_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu
integer(psb_ipk_) :: n_row,n_col
type(psb_z_vect_type) :: wv, wv1
type(psb_z_vect_type) :: tw, tw1
complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:)
integer(psb_ipk_) :: ictxt,np,me,i, err_act
character :: trans_
@ -124,48 +125,56 @@ subroutine mld_z_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
goto 9999
end if
call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.)
call psb_geasb(wv1,desc_data,info,mold=x%v,scratch=.true.)
select case(trans_)
case('N')
call psb_spsm(zone,sv%l,x,zzero,wv,desc_data,info,&
& trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
if (size(wv) < 2) then
info = psb_err_internal_error_
call psb_errpush(info,name,&
& a_err='invalid wv size')
goto 9999
end if
if (info == psb_success_) call psb_spsm(alpha,sv%u,wv,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_, work=aux)
associate(tw => wv(1), tw1 => wv(2))
case('T')
call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,&
& trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
select case(trans_)
case('N')
call psb_spsm(zone,sv%l,x,zzero,tw,desc_data,info,&
& trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
case('C')
if (info == psb_success_) call psb_spsm(alpha,sv%u,tw,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_, work=aux)
call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
case('T')
call psb_spsm(zone,sv%u,x,zzero,tw,desc_data,info,&
& trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux)
if (info == psb_success_) call psb_spsm(alpha,sv%l,tw,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
call wv1%mlt(zone,sv%dv,wv,zzero,info,conjgx=trans_)
case('C')
if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
call psb_spsm(zone,sv%u,x,zzero,tw,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Invalid TRANS in ILU subsolve')
goto 9999
end select
call tw1%mlt(zone,sv%dv,tw,zzero,info,conjgx=trans_)
if (info == psb_success_) call psb_spsm(alpha,sv%l,tw1,beta,y,desc_data,info,&
& trans=trans_,scale='U',choice=psb_none_,work=aux)
if (info /= psb_success_) then
case default
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Invalid TRANS in ILU subsolve')
goto 9999
end select
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
call wv%free(info)
call wv1%free(info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in subsolve')
goto 9999
endif
end associate
if (n_col <= size(work)) then
if ((4*n_col+n_col) <= size(work)) then
else

5
mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90
Unescape Escape View File

@ -40,7 +40,7 @@
!
!
subroutine z_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
use mld_z_mumps_solver
implicit none
@ -49,8 +49,9 @@ subroutine z_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
type(psb_z_vect_type),intent(inout) :: x
type(psb_z_vect_type),intent(inout) :: y
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu

4
mlprec/mld_base_prec_type.F90
Unescape Escape View File

@ -81,10 +81,10 @@ module mld_base_prec_type
!
! Version numbers
!
character(len=*), parameter :: mld_version_string_ = "2.1.0"
character(len=*), parameter :: mld_version_string_ = "2.1.1"
integer(psb_ipk_), parameter :: mld_version_major_ = 2
integer(psb_ipk_), parameter :: mld_version_minor_ = 1
integer(psb_ipk_), parameter :: mld_patchlevel_ = 0
integer(psb_ipk_), parameter :: mld_patchlevel_ = 1
type mld_ml_parms
integer(psb_ipk_) :: sweeps_pre, sweeps_post

17
mlprec/mld_c_as_smoother.f90
Unescape Escape View File

@ -91,6 +91,7 @@ module mld_c_as_smoother
procedure, pass(sm) :: sizeof => c_as_smoother_sizeof
procedure, pass(sm) :: default => c_as_smoother_default
procedure, pass(sm) :: get_nzeros => c_as_smoother_get_nzeros
procedure, pass(sm) :: get_wrksz => c_as_smoother_get_wrksize
procedure, nopass :: get_fmt => c_as_smoother_get_fmt
procedure, nopass :: get_id => c_as_smoother_get_id
end type mld_c_as_smoother_type
@ -98,7 +99,8 @@ module mld_c_as_smoother
private :: c_as_smoother_descr, c_as_smoother_sizeof, &
& c_as_smoother_default, c_as_smoother_get_nzeros, &
& c_as_smoother_get_fmt, c_as_smoother_get_id
& c_as_smoother_get_fmt, c_as_smoother_get_id, &
& c_as_smoother_get_wrksize
character(len=6), parameter, private :: &
& restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/)
@ -179,7 +181,7 @@ module mld_c_as_smoother
interface
subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
& trans,sweeps,work,info,init,initu)
& trans,sweeps,work,wv,info,init,initu)
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
& psb_spk_, mld_c_as_smoother_type, psb_long_int_k_, &
& psb_desc_type, psb_ipk_
@ -192,6 +194,7 @@ module mld_c_as_smoother
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu
@ -457,6 +460,16 @@ contains
end subroutine c_as_smoother_descr
function c_as_smoother_get_wrksize(sm) result(val)
implicit none
class(mld_c_as_smoother_type), intent(inout) :: sm
integer(psb_ipk_) :: val
val = 3
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
end function c_as_smoother_get_wrksize
function c_as_smoother_get_fmt() result(val)
implicit none
character(len=32) :: val

20
mlprec/mld_c_base_smoother_mod.f90
Unescape Escape View File

@ -92,6 +92,10 @@ module mld_c_base_smoother_mod
! check - Sanity checks.
! sizeof - Total memory occupation in bytes
! get_nzeros - Number of nonzeros
! stringval - convert string to val for internal parms
! get_fmt - short string descriptor
! get_id - numeric id descriptro
! get_wrksz - How many workspace vector does apply_vect need
!
!
!
@ -119,6 +123,7 @@ module mld_c_base_smoother_mod
procedure, pass(sm) :: descr => mld_c_base_smoother_descr
procedure, pass(sm) :: sizeof => c_base_smoother_sizeof
procedure, pass(sm) :: get_nzeros => c_base_smoother_get_nzeros
procedure, pass(sm) :: get_wrksz => c_base_smoother_get_wrksize
procedure, nopass :: stringval => mld_stringval
procedure, nopass :: get_fmt => c_base_smoother_get_fmt
procedure, nopass :: get_id => c_base_smoother_get_id
@ -127,7 +132,7 @@ module mld_c_base_smoother_mod
private :: c_base_smoother_sizeof, c_base_smoother_get_fmt, &
& c_base_smoother_default, c_base_smoother_get_nzeros, &
& c_base_smoother_get_id
& c_base_smoother_get_id, c_base_smoother_get_wrksize
@ -153,7 +158,7 @@ module mld_c_base_smoother_mod
interface
subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
& trans,sweeps,work,info,init,initu)
& trans,sweeps,work,wv,info,init,initu)
import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
& psb_c_vect_type, psb_c_base_vect_type, psb_spk_, &
& mld_c_base_smoother_type, psb_ipk_
@ -165,6 +170,7 @@ module mld_c_base_smoother_mod
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu
@ -386,6 +392,16 @@ contains
return
end subroutine c_base_smoother_default
function c_base_smoother_get_wrksize(sm) result(val)
implicit none
class(mld_c_base_smoother_type), intent(inout) :: sm
integer(psb_ipk_) :: val
val = 0
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
end function c_base_smoother_get_wrksize
function c_base_smoother_get_fmt() result(val)
implicit none
character(len=32) :: val

18
mlprec/mld_c_base_solver_mod.f90
Unescape Escape View File

@ -78,7 +78,10 @@ module mld_c_base_solver_mod
! check - Sanity checks.
! sizeof - Total memory occupation in bytes
! get_nzeros - Number of nonzeros
!
! stringval - convert string to val for internal parms
! get_fmt - short string descriptor
! get_id - numeric id descriptro
! get_wrksz - How many workspace vector does apply_vect need
!
!
@ -104,6 +107,7 @@ module mld_c_base_solver_mod
procedure, pass(sv) :: descr => mld_c_base_solver_descr
procedure, pass(sv) :: sizeof => c_base_solver_sizeof
procedure, pass(sv) :: get_nzeros => c_base_solver_get_nzeros
procedure, nopass :: get_wrksz => c_base_solver_get_wrksize
procedure, nopass :: stringval => mld_stringval
procedure, nopass :: get_fmt => c_base_solver_get_fmt
procedure, nopass :: get_id => c_base_solver_get_id
@ -112,7 +116,8 @@ module mld_c_base_solver_mod
private :: c_base_solver_sizeof, c_base_solver_default,&
& c_base_solver_get_nzeros, c_base_solver_get_fmt, &
& c_base_solver_is_iterative, c_base_solver_get_id
& c_base_solver_is_iterative, c_base_solver_get_id, &
& c_base_solver_get_wrksize
interface
@ -138,7 +143,7 @@ module mld_c_base_solver_mod
interface
subroutine mld_c_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
& psb_c_vect_type, psb_c_base_vect_type, psb_spk_, &
& mld_c_base_solver_type, psb_ipk_
@ -150,6 +155,7 @@ module mld_c_base_solver_mod
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu
@ -411,5 +417,11 @@ contains
val = mld_f_none_
end function c_base_solver_get_id
function c_base_solver_get_wrksize() result(val)
implicit none
integer(psb_ipk_) :: val
val = 0
end function c_base_solver_get_wrksize
end module mld_c_base_solver_mod

3
mlprec/mld_c_diag_solver.f90
Unescape Escape View File

@ -76,7 +76,7 @@ module mld_c_diag_solver
interface
subroutine mld_c_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
& psb_c_vect_type, psb_c_base_vect_type, psb_spk_, &
& mld_c_diag_solver_type, psb_ipk_
@ -87,6 +87,7 @@ module mld_c_diag_solver
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu

16
mlprec/mld_c_gs_solver.f90
Unescape Escape View File

@ -77,6 +77,7 @@ module mld_c_gs_solver
procedure, pass(sv) :: default => c_gs_solver_default
procedure, pass(sv) :: sizeof => c_gs_solver_sizeof
procedure, pass(sv) :: get_nzeros => c_gs_solver_get_nzeros
procedure, nopass :: get_wrksz => c_gs_solver_get_wrksize
procedure, nopass :: get_fmt => c_gs_solver_get_fmt
procedure, nopass :: get_id => c_gs_solver_get_id
procedure, nopass :: is_iterative => c_gs_solver_is_iterative
@ -102,11 +103,11 @@ module mld_c_gs_solver
& c_gs_solver_get_fmt, c_gs_solver_check,&
& c_gs_solver_is_iterative, &
& c_bwgs_solver_get_fmt, c_bwgs_solver_descr, &
& c_gs_solver_get_id, c_bwgs_solver_get_id
& c_gs_solver_get_id, c_bwgs_solver_get_id, c_gs_solver_get_wrksize
interface
subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, mld_c_gs_solver_type, psb_c_vect_type, psb_spk_, &
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_
implicit none
@ -117,12 +118,13 @@ module mld_c_gs_solver
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu
end subroutine mld_c_gs_solver_apply_vect
subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, mld_c_bwgs_solver_type, psb_c_vect_type, psb_spk_, &
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_
implicit none
@ -133,6 +135,7 @@ module mld_c_gs_solver
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu
@ -642,4 +645,11 @@ contains
val = mld_bwgs_
end function c_bwgs_solver_get_id
function c_gs_solver_get_wrksize() result(val)
implicit none
integer(psb_ipk_) :: val
val = 2
end function c_gs_solver_get_wrksize
end module mld_c_gs_solver

3
mlprec/mld_c_id_solver.f90
Unescape Escape View File

@ -64,7 +64,7 @@ module mld_c_id_solver
interface
subroutine mld_c_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
& psb_c_vect_type, psb_c_base_vect_type, psb_spk_, &
& mld_c_id_solver_type, psb_ipk_
@ -75,6 +75,7 @@ module mld_c_id_solver
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu

14
mlprec/mld_c_ilu_solver.f90
Unescape Escape View File

@ -85,6 +85,7 @@ module mld_c_ilu_solver
procedure, pass(sv) :: default => c_ilu_solver_default
procedure, pass(sv) :: sizeof => c_ilu_solver_sizeof
procedure, pass(sv) :: get_nzeros => c_ilu_solver_get_nzeros
procedure, nopass :: get_wrksz => c_ilu_solver_get_wrksize
procedure, nopass :: get_fmt => c_ilu_solver_get_fmt
procedure, nopass :: get_id => c_ilu_solver_get_id
end type mld_c_ilu_solver_type
@ -96,12 +97,13 @@ module mld_c_ilu_solver
& c_ilu_solver_descr, c_ilu_solver_sizeof, &
& c_ilu_solver_default, c_ilu_solver_dmp, &
& c_ilu_solver_apply_vect, c_ilu_solver_get_nzeros, &
& c_ilu_solver_get_fmt, c_ilu_solver_check, c_ilu_solver_get_id
& c_ilu_solver_get_fmt, c_ilu_solver_check, &
& c_ilu_solver_get_id, c_ilu_solver_get_wrksize
interface
subroutine mld_c_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, mld_c_ilu_solver_type, psb_c_vect_type, psb_spk_, &
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_
implicit none
@ -112,6 +114,7 @@ module mld_c_ilu_solver
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu
@ -554,5 +557,12 @@ contains
val = mld_ilu_n_
end function c_ilu_solver_get_id
function c_ilu_solver_get_wrksize() result(val)
implicit none
integer(psb_ipk_) :: val
val = 2
end function c_ilu_solver_get_wrksize
end module mld_c_ilu_solver

3
mlprec/mld_c_inner_mod.f90
Unescape Escape View File

@ -48,7 +48,8 @@ module mld_c_inner_mod
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_i_base_vect_type, &
& psb_spk_, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_, &
& psb_c_vect_type
use mld_c_prec_type, only : mld_cprec_type, mld_sml_parms, mld_c_onelev_type
use mld_c_prec_type, only : mld_cprec_type, mld_sml_parms, &
& mld_c_onelev_type, mld_cmlprec_wrk_type
interface mld_mlprec_bld
subroutine mld_cmlprec_bld(a,desc_a,prec,info, amold, vmold,imold)

17
mlprec/mld_c_jac_smoother.f90
Unescape Escape View File

@ -71,6 +71,7 @@ module mld_c_jac_smoother
procedure, pass(sm) :: descr => mld_c_jac_smoother_descr
procedure, pass(sm) :: sizeof => c_jac_smoother_sizeof
procedure, pass(sm) :: get_nzeros => c_jac_smoother_get_nzeros
procedure, pass(sm) :: get_wrksz => c_jac_smoother_get_wrksize
procedure, nopass :: get_fmt => c_jac_smoother_get_fmt
procedure, nopass :: get_id => c_jac_smoother_get_id
end type mld_c_jac_smoother_type
@ -78,12 +79,13 @@ module mld_c_jac_smoother
private :: c_jac_smoother_free, c_jac_smoother_descr, &
& c_jac_smoother_sizeof, c_jac_smoother_get_nzeros, &
& c_jac_smoother_get_fmt, c_jac_smoother_get_id
& c_jac_smoother_get_fmt, c_jac_smoother_get_id, &
& c_jac_smoother_get_wrksize
interface
subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info,init,initu)
& sweeps,work,wv,info,init,initu)
import :: psb_desc_type, mld_c_jac_smoother_type, psb_c_vect_type, psb_spk_, &
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type,&
& psb_ipk_
@ -96,6 +98,7 @@ module mld_c_jac_smoother
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu
@ -252,6 +255,16 @@ contains
return
end function c_jac_smoother_get_nzeros
function c_jac_smoother_get_wrksize(sm) result(val)
implicit none
class(mld_c_jac_smoother_type), intent(inout) :: sm
integer(psb_ipk_) :: val
val = 2
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
end function c_jac_smoother_get_wrksize
function c_jac_smoother_get_fmt() result(val)
implicit none
character(len=32) :: val

5
mlprec/mld_c_mumps_solver.F90
Unescape Escape View File

@ -103,7 +103,7 @@ module mld_c_mumps_solver
interface
subroutine c_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, mld_c_mumps_solver_type, psb_c_vect_type, psb_dpk_, psb_spk_, &
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_
implicit none
@ -112,8 +112,9 @@ module mld_c_mumps_solver
type(psb_c_vect_type),intent(inout) :: x
type(psb_c_vect_type),intent(inout) :: y
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
type(psb_c_vect_type),intent(inout) :: wv(:)
integer, intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu

209
mlprec/mld_c_onelev_mod.f90
Unescape Escape View File

@ -117,11 +117,27 @@ module mld_c_onelev_mod
! check - Sanity checks.
! sizeof - Total memory occupation in bytes
! get_nzeros - Number of nonzeros
! get_wrksz - How many workspace vector does apply_vect need
!
!
!
type mld_cmlprec_wrk_type
complex(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:)
type(psb_c_vect_type) :: vtx, vty, vx2l, vy2l
integer(psb_ipk_) :: wvsz = 0
type(psb_c_vect_type), allocatable :: wv(:)
contains
procedure, pass(wk) :: alloc => c_wrk_alloc
procedure, pass(wk) :: free => c_wrk_free
procedure, pass(wk) :: clone => c_wrk_clone
procedure, pass(wk) :: move_alloc => c_wrk_move_alloc
end type mld_cmlprec_wrk_type
private :: c_wrk_alloc, c_wrk_free, &
& c_wrk_clone, c_wrk_move_alloc
type mld_c_onelev_type
class(mld_c_base_smoother_type), allocatable :: sm, sm2a
class(mld_c_base_smoother_type), pointer :: sm2 => null()
class(mld_cmlprec_wrk_type), allocatable :: wrk
type(mld_sml_parms) :: parms
type(psb_cspmat_type) :: ac
integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot
@ -153,6 +169,9 @@ module mld_c_onelev_mod
& cseti, csetr, csetc, setsm, setsv
procedure, pass(lv) :: sizeof => c_base_onelev_sizeof
procedure, pass(lv) :: get_nzeros => c_base_onelev_get_nzeros
procedure, pass(lv) :: get_wrksz => c_base_onelev_get_wrksize
procedure, pass(lv) :: allocate_wrk => c_base_onelev_allocate_wrk
procedure, pass(lv) :: free_wrk => c_base_onelev_free_wrk
procedure, nopass :: stringval => mld_stringval
procedure, pass(lv) :: move_alloc => c_base_onelev_move_alloc
end type mld_c_onelev_type
@ -164,7 +183,9 @@ module mld_c_onelev_mod
private :: c_base_onelev_default, c_base_onelev_sizeof, &
& c_base_onelev_nullify, c_base_onelev_get_nzeros, &
& c_base_onelev_clone, c_base_onelev_move_alloc
& c_base_onelev_clone, c_base_onelev_move_alloc, &
& c_base_onelev_get_wrksize, c_base_onelev_allocate_wrk, &
& c_base_onelev_free_wrk
@ -498,7 +519,6 @@ contains
end subroutine c_base_onelev_clone
subroutine c_base_onelev_move_alloc(lv, b,info)
use psb_base_mod
implicit none
@ -527,4 +547,187 @@ contains
end subroutine c_base_onelev_move_alloc
function c_base_onelev_get_wrksize(lv) result(val)
implicit none
class(mld_c_onelev_type), intent(inout) :: lv
integer(psb_ipk_) :: val
val = 0
! SM and SM2A can share work vectors
if (allocated(lv%sm)) val = val + lv%sm%get_wrksz()
if (allocated(lv%sm2a)) val = max(val,lv%sm2a%get_wrksz())
!
! Now for the ML application itself
!
! VTX/VTY/VX2L/VY2L are stored explicitly
!
!
! additions for specific ML/cycles
!
select case(lv%parms%ml_cycle)
case(mld_add_ml_,mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_)
! We're good
case(mld_kcycle_ml_, mld_kcyclesym_ml_)
!
! We need 7 in inneritkcycle.
! Can we reuse vtx?
!
val = val + 7
case default
! Need a better error signaling ?
val = -1
end select
end function c_base_onelev_get_wrksize
subroutine c_base_onelev_allocate_wrk(lv,info,vmold)
use psb_base_mod
implicit none
class(mld_c_onelev_type), target, intent(inout) :: lv
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type), intent(in), optional :: vmold
!
integer(psb_ipk_) :: nwv, i
info = psb_success_
nwv = lv%get_wrksz()
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
if (info == 0) call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
end subroutine c_base_onelev_allocate_wrk
subroutine c_base_onelev_free_wrk(lv,info)
use psb_base_mod
implicit none
class(mld_c_onelev_type), target, intent(inout) :: lv
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: nwv,i
info = psb_success_
if (allocated(lv%wrk)) then
call lv%wrk%free(info)
if (info == 0) deallocate(lv%wrk,stat=info)
end if
end subroutine c_base_onelev_free_wrk
subroutine c_wrk_alloc(wk,nwv,desc,info,vmold)
use psb_base_mod
Implicit None
! Arguments
class(mld_cmlprec_wrk_type), target, intent(inout) :: wk
integer(psb_ipk_), intent(in) :: nwv
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type), intent(in), optional :: vmold
!
integer(psb_ipk_) :: i
info = psb_success_
call wk%free(info)
call psb_geasb(wk%vx2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc,info,&
& scratch=.true.,mold=vmold)
end do
end subroutine c_wrk_alloc
subroutine c_wrk_free(wk,info)
Implicit None
! Arguments
class(mld_cmlprec_wrk_type), target, intent(inout) :: wk
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: i
info = psb_success_
if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
call wk%vtx%free(info)
call wk%vty%free(info)
call wk%vx2l%free(info)
call wk%vy2l%free(info)
if (allocated(wk%wv)) then
do i=1,size(wk%wv)
call wk%wv(i)%free(info)
end do
deallocate(wk%wv, stat=info)
end if
end subroutine c_wrk_free
subroutine c_wrk_clone(wk,wkout,info)
use psb_base_mod
Implicit None
! Arguments
class(mld_cmlprec_wrk_type), target, intent(inout) :: wk
class(mld_cmlprec_wrk_type), target, intent(inout) :: wkout
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: i
info = psb_success_
call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
call wk%vtx%clone(wkout%vtx,info)
call wk%vty%clone(wkout%vty,info)
call wk%vx2l%clone(wkout%vx2l,info)
call wk%vy2l%clone(wkout%vy2l,info)
if (allocated(wkout%wv)) then
do i=1,size(wkout%wv)
call wkout%wv(i)%free(info)
end do
deallocate( wkout%wv)
end if
allocate(wkout%wv(size(wk%wv)),stat=info)
do i=1,size(wk%wv)
call wk%wv(i)%clone(wkout%wv(i),info)
end do
return
end subroutine c_wrk_clone
subroutine c_wrk_move_alloc(wk, b,info)
implicit none
class(mld_cmlprec_wrk_type), target, intent(inout) :: wk, b
integer(psb_ipk_), intent(out) :: info
call b%free(info)
call move_alloc(wk%tx,b%tx)
call move_alloc(wk%ty,b%ty)
call move_alloc(wk%x2l,b%x2l)
call move_alloc(wk%y2l,b%y2l)
!
! Should define V%move_alloc....
call move_alloc(wk%vtx%v,b%vtx%v)
call move_alloc(wk%vty%v,b%vty%v)
call move_alloc(wk%vx2l%v,b%vx2l%v)
call move_alloc(wk%vy2l%v,b%vy2l%v)
call move_alloc(wk%wv,b%wv)
end subroutine c_wrk_move_alloc
end module mld_c_onelev_mod

83
mlprec/mld_c_prec_type.f90
Unescape Escape View File

@ -80,7 +80,8 @@ module mld_c_prec_type
! order, with level 0 being the id of the coarsest level.
!
!
integer, parameter, private :: wv_size_=4
type, extends(psb_cprec_type) :: mld_cprec_type
integer(psb_ipk_) :: ictxt
!
@ -116,6 +117,8 @@ module mld_c_prec_type
procedure, pass(prec) :: dump => mld_c_dump
procedure, pass(prec) :: clone => mld_c_clone
procedure, pass(prec) :: free => mld_c_prec_free
procedure, pass(prec) :: allocate_wrk => mld_c_allocate_wrk
procedure, pass(prec) :: free_wrk => mld_c_free_wrk
procedure, pass(prec) :: get_complexity => mld_c_get_compl
procedure, pass(prec) :: cmp_complexity => mld_c_cmp_compl
procedure, pass(prec) :: get_nlevs => mld_c_get_nlevs
@ -552,7 +555,7 @@ contains
call psb_erractionsave(err_act)
me=-1
call prec%free_wrk(info)
if (allocated(prec%precv)) then
do i=1,size(prec%precv)
call prec%precv(i)%free(info)
@ -778,6 +781,9 @@ contains
end if
end do
end if
if (allocated(prec%precv(1)%wrk)) &
& call pout%allocate_wrk(info,vmold=prec%precv(1)%wrk%vx2l%v)
class default
write(0,*) 'Error: wrong out type'
info = psb_err_invalid_input_
@ -811,10 +817,81 @@ contains
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
else
write(0,*) 'Warning: PREC%move_alloc onto different type?'
info = psb_err_internal_error_
end if
end subroutine c_prec_move_alloc
subroutine mld_c_allocate_wrk(prec,info,vmold)
use psb_base_mod
implicit none
! Arguments
class(mld_cprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type), intent(in), optional :: vmold
! Local variables
integer(psb_ipk_) :: me,err_act,i,j,level,nlev, nc2l
character(len=20) :: name
if(psb_get_errstatus().ne.0) return
info=psb_success_
name = 'mld_c_allocate_wrk'
call psb_erractionsave(err_act)
nlev = size(prec%precv)
level = 1
do level = 1, nlev
call prec%precv(level)%allocate_wrk(info,vmold=vmold)
if (psb_errstatus_fatal()) then
nc2l = prec%precv(level)%base_desc%get_local_cols()
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),&
& a_err='complex(psb_spk_)')
goto 9999
end if
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_c_allocate_wrk
subroutine mld_c_free_wrk(prec,info)
use psb_base_mod
implicit none
! Arguments
class(mld_cprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: me,err_act,i,j,level, nlev, nc2l
character(len=20) :: name
if(psb_get_errstatus().ne.0) return
info=psb_success_
name = 'mld_c_free_wrk'
call psb_erractionsave(err_act)
nlev = size(prec%precv)
do level = 1, nlev
call prec%precv(level)%free_wrk(info)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_c_free_wrk
end module mld_c_prec_type

7
mlprec/mld_c_slu_solver.F90
Unescape Escape View File

@ -211,7 +211,7 @@ contains
end subroutine c_slu_solver_apply
subroutine c_slu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
implicit none
type(psb_desc_type), intent(in) :: desc_data
@ -219,9 +219,10 @@ contains
type(psb_c_vect_type),intent(inout) :: x
type(psb_c_vect_type),intent(inout) :: y
complex(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
character(len=1),intent(in) :: trans
complex(psb_spk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
type(psb_c_vect_type),intent(inout) :: wv(:)
integer, intent(out) :: info
character, intent(in), optional :: init
type(psb_c_vect_type),intent(inout), optional :: initu

17
mlprec/mld_d_as_smoother.f90
Unescape Escape View File

@ -91,6 +91,7 @@ module mld_d_as_smoother
procedure, pass(sm) :: sizeof => d_as_smoother_sizeof
procedure, pass(sm) :: default => d_as_smoother_default
procedure, pass(sm) :: get_nzeros => d_as_smoother_get_nzeros
procedure, pass(sm) :: get_wrksz => d_as_smoother_get_wrksize
procedure, nopass :: get_fmt => d_as_smoother_get_fmt
procedure, nopass :: get_id => d_as_smoother_get_id
end type mld_d_as_smoother_type
@ -98,7 +99,8 @@ module mld_d_as_smoother
private :: d_as_smoother_descr, d_as_smoother_sizeof, &
& d_as_smoother_default, d_as_smoother_get_nzeros, &
& d_as_smoother_get_fmt, d_as_smoother_get_id
& d_as_smoother_get_fmt, d_as_smoother_get_id, &
& d_as_smoother_get_wrksize
character(len=6), parameter, private :: &
& restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/)
@ -179,7 +181,7 @@ module mld_d_as_smoother
interface
subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
& trans,sweeps,work,info,init,initu)
& trans,sweeps,work,wv,info,init,initu)
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
& psb_dpk_, mld_d_as_smoother_type, psb_long_int_k_, &
& psb_desc_type, psb_ipk_
@ -192,6 +194,7 @@ module mld_d_as_smoother
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
@ -457,6 +460,16 @@ contains
end subroutine d_as_smoother_descr
function d_as_smoother_get_wrksize(sm) result(val)
implicit none
class(mld_d_as_smoother_type), intent(inout) :: sm
integer(psb_ipk_) :: val
val = 3
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
end function d_as_smoother_get_wrksize
function d_as_smoother_get_fmt() result(val)
implicit none
character(len=32) :: val

20
mlprec/mld_d_base_smoother_mod.f90
Unescape Escape View File

@ -92,6 +92,10 @@ module mld_d_base_smoother_mod
! check - Sanity checks.
! sizeof - Total memory occupation in bytes
! get_nzeros - Number of nonzeros
! stringval - convert string to val for internal parms
! get_fmt - short string descriptor
! get_id - numeric id descriptro
! get_wrksz - How many workspace vector does apply_vect need
!
!
!
@ -119,6 +123,7 @@ module mld_d_base_smoother_mod
procedure, pass(sm) :: descr => mld_d_base_smoother_descr
procedure, pass(sm) :: sizeof => d_base_smoother_sizeof
procedure, pass(sm) :: get_nzeros => d_base_smoother_get_nzeros
procedure, pass(sm) :: get_wrksz => d_base_smoother_get_wrksize
procedure, nopass :: stringval => mld_stringval
procedure, nopass :: get_fmt => d_base_smoother_get_fmt
procedure, nopass :: get_id => d_base_smoother_get_id
@ -127,7 +132,7 @@ module mld_d_base_smoother_mod
private :: d_base_smoother_sizeof, d_base_smoother_get_fmt, &
& d_base_smoother_default, d_base_smoother_get_nzeros, &
& d_base_smoother_get_id
& d_base_smoother_get_id, d_base_smoother_get_wrksize
@ -153,7 +158,7 @@ module mld_d_base_smoother_mod
interface
subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
& trans,sweeps,work,info,init,initu)
& trans,sweeps,work,wv,info,init,initu)
import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
& psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, &
& mld_d_base_smoother_type, psb_ipk_
@ -165,6 +170,7 @@ module mld_d_base_smoother_mod
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
@ -386,6 +392,16 @@ contains
return
end subroutine d_base_smoother_default
function d_base_smoother_get_wrksize(sm) result(val)
implicit none
class(mld_d_base_smoother_type), intent(inout) :: sm
integer(psb_ipk_) :: val
val = 0
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
end function d_base_smoother_get_wrksize
function d_base_smoother_get_fmt() result(val)
implicit none
character(len=32) :: val

18
mlprec/mld_d_base_solver_mod.f90
Unescape Escape View File

@ -78,7 +78,10 @@ module mld_d_base_solver_mod
! check - Sanity checks.
! sizeof - Total memory occupation in bytes
! get_nzeros - Number of nonzeros
!
! stringval - convert string to val for internal parms
! get_fmt - short string descriptor
! get_id - numeric id descriptro
! get_wrksz - How many workspace vector does apply_vect need
!
!
@ -104,6 +107,7 @@ module mld_d_base_solver_mod
procedure, pass(sv) :: descr => mld_d_base_solver_descr
procedure, pass(sv) :: sizeof => d_base_solver_sizeof
procedure, pass(sv) :: get_nzeros => d_base_solver_get_nzeros
procedure, nopass :: get_wrksz => d_base_solver_get_wrksize
procedure, nopass :: stringval => mld_stringval
procedure, nopass :: get_fmt => d_base_solver_get_fmt
procedure, nopass :: get_id => d_base_solver_get_id
@ -112,7 +116,8 @@ module mld_d_base_solver_mod
private :: d_base_solver_sizeof, d_base_solver_default,&
& d_base_solver_get_nzeros, d_base_solver_get_fmt, &
& d_base_solver_is_iterative, d_base_solver_get_id
& d_base_solver_is_iterative, d_base_solver_get_id, &
& d_base_solver_get_wrksize
interface
@ -138,7 +143,7 @@ module mld_d_base_solver_mod
interface
subroutine mld_d_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
& psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, &
& mld_d_base_solver_type, psb_ipk_
@ -150,6 +155,7 @@ module mld_d_base_solver_mod
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
@ -411,5 +417,11 @@ contains
val = mld_f_none_
end function d_base_solver_get_id
function d_base_solver_get_wrksize() result(val)
implicit none
integer(psb_ipk_) :: val
val = 0
end function d_base_solver_get_wrksize
end module mld_d_base_solver_mod

3
mlprec/mld_d_diag_solver.f90
Unescape Escape View File

@ -76,7 +76,7 @@ module mld_d_diag_solver
interface
subroutine mld_d_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
& psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, &
& mld_d_diag_solver_type, psb_ipk_
@ -87,6 +87,7 @@ module mld_d_diag_solver
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu

16
mlprec/mld_d_gs_solver.f90
Unescape Escape View File

@ -77,6 +77,7 @@ module mld_d_gs_solver
procedure, pass(sv) :: default => d_gs_solver_default
procedure, pass(sv) :: sizeof => d_gs_solver_sizeof
procedure, pass(sv) :: get_nzeros => d_gs_solver_get_nzeros
procedure, nopass :: get_wrksz => d_gs_solver_get_wrksize
procedure, nopass :: get_fmt => d_gs_solver_get_fmt
procedure, nopass :: get_id => d_gs_solver_get_id
procedure, nopass :: is_iterative => d_gs_solver_is_iterative
@ -102,11 +103,11 @@ module mld_d_gs_solver
& d_gs_solver_get_fmt, d_gs_solver_check,&
& d_gs_solver_is_iterative, &
& d_bwgs_solver_get_fmt, d_bwgs_solver_descr, &
& d_gs_solver_get_id, d_bwgs_solver_get_id
& d_gs_solver_get_id, d_bwgs_solver_get_id, d_gs_solver_get_wrksize
interface
subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, mld_d_gs_solver_type, psb_d_vect_type, psb_dpk_, &
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_
implicit none
@ -117,12 +118,13 @@ module mld_d_gs_solver
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
end subroutine mld_d_gs_solver_apply_vect
subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, mld_d_bwgs_solver_type, psb_d_vect_type, psb_dpk_, &
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_
implicit none
@ -133,6 +135,7 @@ module mld_d_gs_solver
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
@ -642,4 +645,11 @@ contains
val = mld_bwgs_
end function d_bwgs_solver_get_id
function d_gs_solver_get_wrksize() result(val)
implicit none
integer(psb_ipk_) :: val
val = 2
end function d_gs_solver_get_wrksize
end module mld_d_gs_solver

3
mlprec/mld_d_id_solver.f90
Unescape Escape View File

@ -64,7 +64,7 @@ module mld_d_id_solver
interface
subroutine mld_d_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
& psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, &
& mld_d_id_solver_type, psb_ipk_
@ -75,6 +75,7 @@ module mld_d_id_solver
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu

14
mlprec/mld_d_ilu_solver.f90
Unescape Escape View File

@ -85,6 +85,7 @@ module mld_d_ilu_solver
procedure, pass(sv) :: default => d_ilu_solver_default
procedure, pass(sv) :: sizeof => d_ilu_solver_sizeof
procedure, pass(sv) :: get_nzeros => d_ilu_solver_get_nzeros
procedure, nopass :: get_wrksz => d_ilu_solver_get_wrksize
procedure, nopass :: get_fmt => d_ilu_solver_get_fmt
procedure, nopass :: get_id => d_ilu_solver_get_id
end type mld_d_ilu_solver_type
@ -96,12 +97,13 @@ module mld_d_ilu_solver
& d_ilu_solver_descr, d_ilu_solver_sizeof, &
& d_ilu_solver_default, d_ilu_solver_dmp, &
& d_ilu_solver_apply_vect, d_ilu_solver_get_nzeros, &
& d_ilu_solver_get_fmt, d_ilu_solver_check, d_ilu_solver_get_id
& d_ilu_solver_get_fmt, d_ilu_solver_check, &
& d_ilu_solver_get_id, d_ilu_solver_get_wrksize
interface
subroutine mld_d_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, mld_d_ilu_solver_type, psb_d_vect_type, psb_dpk_, &
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_
implicit none
@ -112,6 +114,7 @@ module mld_d_ilu_solver
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
@ -554,5 +557,12 @@ contains
val = mld_ilu_n_
end function d_ilu_solver_get_id
function d_ilu_solver_get_wrksize() result(val)
implicit none
integer(psb_ipk_) :: val
val = 2
end function d_ilu_solver_get_wrksize
end module mld_d_ilu_solver

3
mlprec/mld_d_inner_mod.f90
Unescape Escape View File

@ -48,7 +48,8 @@ module mld_d_inner_mod
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_i_base_vect_type, &
& psb_dpk_, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_, &
& psb_d_vect_type
use mld_d_prec_type, only : mld_dprec_type, mld_dml_parms, mld_d_onelev_type
use mld_d_prec_type, only : mld_dprec_type, mld_dml_parms, &
& mld_d_onelev_type, mld_dmlprec_wrk_type
interface mld_mlprec_bld
subroutine mld_dmlprec_bld(a,desc_a,prec,info, amold, vmold,imold)

17
mlprec/mld_d_jac_smoother.f90
Unescape Escape View File

@ -71,6 +71,7 @@ module mld_d_jac_smoother
procedure, pass(sm) :: descr => mld_d_jac_smoother_descr
procedure, pass(sm) :: sizeof => d_jac_smoother_sizeof
procedure, pass(sm) :: get_nzeros => d_jac_smoother_get_nzeros
procedure, pass(sm) :: get_wrksz => d_jac_smoother_get_wrksize
procedure, nopass :: get_fmt => d_jac_smoother_get_fmt
procedure, nopass :: get_id => d_jac_smoother_get_id
end type mld_d_jac_smoother_type
@ -78,12 +79,13 @@ module mld_d_jac_smoother
private :: d_jac_smoother_free, d_jac_smoother_descr, &
& d_jac_smoother_sizeof, d_jac_smoother_get_nzeros, &
& d_jac_smoother_get_fmt, d_jac_smoother_get_id
& d_jac_smoother_get_fmt, d_jac_smoother_get_id, &
& d_jac_smoother_get_wrksize
interface
subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info,init,initu)
& sweeps,work,wv,info,init,initu)
import :: psb_desc_type, mld_d_jac_smoother_type, psb_d_vect_type, psb_dpk_, &
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,&
& psb_ipk_
@ -96,6 +98,7 @@ module mld_d_jac_smoother
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu
@ -252,6 +255,16 @@ contains
return
end function d_jac_smoother_get_nzeros
function d_jac_smoother_get_wrksize(sm) result(val)
implicit none
class(mld_d_jac_smoother_type), intent(inout) :: sm
integer(psb_ipk_) :: val
val = 2
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
end function d_jac_smoother_get_wrksize
function d_jac_smoother_get_fmt() result(val)
implicit none
character(len=32) :: val

5
mlprec/mld_d_mumps_solver.F90
Unescape Escape View File

@ -103,7 +103,7 @@ module mld_d_mumps_solver
interface
subroutine d_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, mld_d_mumps_solver_type, psb_d_vect_type, psb_dpk_, psb_spk_, &
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_
implicit none
@ -112,8 +112,9 @@ module mld_d_mumps_solver
type(psb_d_vect_type),intent(inout) :: x
type(psb_d_vect_type),intent(inout) :: y
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer, intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu

209
mlprec/mld_d_onelev_mod.f90
Unescape Escape View File

@ -117,11 +117,27 @@ module mld_d_onelev_mod
! check - Sanity checks.
! sizeof - Total memory occupation in bytes
! get_nzeros - Number of nonzeros
! get_wrksz - How many workspace vector does apply_vect need
!
!
!
type mld_dmlprec_wrk_type
real(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:)
type(psb_d_vect_type) :: vtx, vty, vx2l, vy2l
integer(psb_ipk_) :: wvsz = 0
type(psb_d_vect_type), allocatable :: wv(:)
contains
procedure, pass(wk) :: alloc => d_wrk_alloc
procedure, pass(wk) :: free => d_wrk_free
procedure, pass(wk) :: clone => d_wrk_clone
procedure, pass(wk) :: move_alloc => d_wrk_move_alloc
end type mld_dmlprec_wrk_type
private :: d_wrk_alloc, d_wrk_free, &
& d_wrk_clone, d_wrk_move_alloc
type mld_d_onelev_type
class(mld_d_base_smoother_type), allocatable :: sm, sm2a
class(mld_d_base_smoother_type), pointer :: sm2 => null()
class(mld_dmlprec_wrk_type), allocatable :: wrk
type(mld_dml_parms) :: parms
type(psb_dspmat_type) :: ac
integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot
@ -153,6 +169,9 @@ module mld_d_onelev_mod
& cseti, csetr, csetc, setsm, setsv
procedure, pass(lv) :: sizeof => d_base_onelev_sizeof
procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros
procedure, pass(lv) :: get_wrksz => d_base_onelev_get_wrksize
procedure, pass(lv) :: allocate_wrk => d_base_onelev_allocate_wrk
procedure, pass(lv) :: free_wrk => d_base_onelev_free_wrk
procedure, nopass :: stringval => mld_stringval
procedure, pass(lv) :: move_alloc => d_base_onelev_move_alloc
end type mld_d_onelev_type
@ -164,7 +183,9 @@ module mld_d_onelev_mod
private :: d_base_onelev_default, d_base_onelev_sizeof, &
& d_base_onelev_nullify, d_base_onelev_get_nzeros, &
& d_base_onelev_clone, d_base_onelev_move_alloc
& d_base_onelev_clone, d_base_onelev_move_alloc, &
& d_base_onelev_get_wrksize, d_base_onelev_allocate_wrk, &
& d_base_onelev_free_wrk
@ -498,7 +519,6 @@ contains
end subroutine d_base_onelev_clone
subroutine d_base_onelev_move_alloc(lv, b,info)
use psb_base_mod
implicit none
@ -527,4 +547,187 @@ contains
end subroutine d_base_onelev_move_alloc
function d_base_onelev_get_wrksize(lv) result(val)
implicit none
class(mld_d_onelev_type), intent(inout) :: lv
integer(psb_ipk_) :: val
val = 0
! SM and SM2A can share work vectors
if (allocated(lv%sm)) val = val + lv%sm%get_wrksz()
if (allocated(lv%sm2a)) val = max(val,lv%sm2a%get_wrksz())
!
! Now for the ML application itself
!
! VTX/VTY/VX2L/VY2L are stored explicitly
!
!
! additions for specific ML/cycles
!
select case(lv%parms%ml_cycle)
case(mld_add_ml_,mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_)
! We're good
case(mld_kcycle_ml_, mld_kcyclesym_ml_)
!
! We need 7 in inneritkcycle.
! Can we reuse vtx?
!
val = val + 7
case default
! Need a better error signaling ?
val = -1
end select
end function d_base_onelev_get_wrksize
subroutine d_base_onelev_allocate_wrk(lv,info,vmold)
use psb_base_mod
implicit none
class(mld_d_onelev_type), target, intent(inout) :: lv
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: vmold
!
integer(psb_ipk_) :: nwv, i
info = psb_success_
nwv = lv%get_wrksz()
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
if (info == 0) call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
end subroutine d_base_onelev_allocate_wrk
subroutine d_base_onelev_free_wrk(lv,info)
use psb_base_mod
implicit none
class(mld_d_onelev_type), target, intent(inout) :: lv
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: nwv,i
info = psb_success_
if (allocated(lv%wrk)) then
call lv%wrk%free(info)
if (info == 0) deallocate(lv%wrk,stat=info)
end if
end subroutine d_base_onelev_free_wrk
subroutine d_wrk_alloc(wk,nwv,desc,info,vmold)
use psb_base_mod
Implicit None
! Arguments
class(mld_dmlprec_wrk_type), target, intent(inout) :: wk
integer(psb_ipk_), intent(in) :: nwv
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: vmold
!
integer(psb_ipk_) :: i
info = psb_success_
call wk%free(info)
call psb_geasb(wk%vx2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc,info,&
& scratch=.true.,mold=vmold)
end do
end subroutine d_wrk_alloc
subroutine d_wrk_free(wk,info)
Implicit None
! Arguments
class(mld_dmlprec_wrk_type), target, intent(inout) :: wk
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: i
info = psb_success_
if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
call wk%vtx%free(info)
call wk%vty%free(info)
call wk%vx2l%free(info)
call wk%vy2l%free(info)
if (allocated(wk%wv)) then
do i=1,size(wk%wv)
call wk%wv(i)%free(info)
end do
deallocate(wk%wv, stat=info)
end if
end subroutine d_wrk_free
subroutine d_wrk_clone(wk,wkout,info)
use psb_base_mod
Implicit None
! Arguments
class(mld_dmlprec_wrk_type), target, intent(inout) :: wk
class(mld_dmlprec_wrk_type), target, intent(inout) :: wkout
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: i
info = psb_success_
call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
call wk%vtx%clone(wkout%vtx,info)
call wk%vty%clone(wkout%vty,info)
call wk%vx2l%clone(wkout%vx2l,info)
call wk%vy2l%clone(wkout%vy2l,info)
if (allocated(wkout%wv)) then
do i=1,size(wkout%wv)
call wkout%wv(i)%free(info)
end do
deallocate( wkout%wv)
end if
allocate(wkout%wv(size(wk%wv)),stat=info)
do i=1,size(wk%wv)
call wk%wv(i)%clone(wkout%wv(i),info)
end do
return
end subroutine d_wrk_clone
subroutine d_wrk_move_alloc(wk, b,info)
implicit none
class(mld_dmlprec_wrk_type), target, intent(inout) :: wk, b
integer(psb_ipk_), intent(out) :: info
call b%free(info)
call move_alloc(wk%tx,b%tx)
call move_alloc(wk%ty,b%ty)
call move_alloc(wk%x2l,b%x2l)
call move_alloc(wk%y2l,b%y2l)
!
! Should define V%move_alloc....
call move_alloc(wk%vtx%v,b%vtx%v)
call move_alloc(wk%vty%v,b%vty%v)
call move_alloc(wk%vx2l%v,b%vx2l%v)
call move_alloc(wk%vy2l%v,b%vy2l%v)
call move_alloc(wk%wv,b%wv)
end subroutine d_wrk_move_alloc
end module mld_d_onelev_mod

83
mlprec/mld_d_prec_type.f90
Unescape Escape View File

@ -80,7 +80,8 @@ module mld_d_prec_type
! order, with level 0 being the id of the coarsest level.
!
!
integer, parameter, private :: wv_size_=4
type, extends(psb_dprec_type) :: mld_dprec_type
integer(psb_ipk_) :: ictxt
!
@ -116,6 +117,8 @@ module mld_d_prec_type
procedure, pass(prec) :: dump => mld_d_dump
procedure, pass(prec) :: clone => mld_d_clone
procedure, pass(prec) :: free => mld_d_prec_free
procedure, pass(prec) :: allocate_wrk => mld_d_allocate_wrk
procedure, pass(prec) :: free_wrk => mld_d_free_wrk
procedure, pass(prec) :: get_complexity => mld_d_get_compl
procedure, pass(prec) :: cmp_complexity => mld_d_cmp_compl
procedure, pass(prec) :: get_nlevs => mld_d_get_nlevs
@ -552,7 +555,7 @@ contains
call psb_erractionsave(err_act)
me=-1
call prec%free_wrk(info)
if (allocated(prec%precv)) then
do i=1,size(prec%precv)
call prec%precv(i)%free(info)
@ -778,6 +781,9 @@ contains
end if
end do
end if
if (allocated(prec%precv(1)%wrk)) &
& call pout%allocate_wrk(info,vmold=prec%precv(1)%wrk%vx2l%v)
class default
write(0,*) 'Error: wrong out type'
info = psb_err_invalid_input_
@ -811,10 +817,81 @@ contains
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
else
write(0,*) 'Warning: PREC%move_alloc onto different type?'
info = psb_err_internal_error_
end if
end subroutine d_prec_move_alloc
subroutine mld_d_allocate_wrk(prec,info,vmold)
use psb_base_mod
implicit none
! Arguments
class(mld_dprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: vmold
! Local variables
integer(psb_ipk_) :: me,err_act,i,j,level,nlev, nc2l
character(len=20) :: name
if(psb_get_errstatus().ne.0) return
info=psb_success_
name = 'mld_d_allocate_wrk'
call psb_erractionsave(err_act)
nlev = size(prec%precv)
level = 1
do level = 1, nlev
call prec%precv(level)%allocate_wrk(info,vmold=vmold)
if (psb_errstatus_fatal()) then
nc2l = prec%precv(level)%base_desc%get_local_cols()
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),&
& a_err='real(psb_dpk_)')
goto 9999
end if
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_d_allocate_wrk
subroutine mld_d_free_wrk(prec,info)
use psb_base_mod
implicit none
! Arguments
class(mld_dprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: me,err_act,i,j,level, nlev, nc2l
character(len=20) :: name
if(psb_get_errstatus().ne.0) return
info=psb_success_
name = 'mld_d_free_wrk'
call psb_erractionsave(err_act)
nlev = size(prec%precv)
do level = 1, nlev
call prec%precv(level)%free_wrk(info)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_d_free_wrk
end module mld_d_prec_type

7
mlprec/mld_d_slu_solver.F90
Unescape Escape View File

@ -211,7 +211,7 @@ contains
end subroutine d_slu_solver_apply
subroutine d_slu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
implicit none
type(psb_desc_type), intent(in) :: desc_data
@ -219,9 +219,10 @@ contains
type(psb_d_vect_type),intent(inout) :: x
type(psb_d_vect_type),intent(inout) :: y
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
type(psb_d_vect_type),intent(inout) :: wv(:)
integer, intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu

7
mlprec/mld_d_sludist_solver.F90
Unescape Escape View File

@ -212,7 +212,7 @@ contains
end subroutine d_sludist_solver_apply
subroutine d_sludist_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
implicit none
type(psb_desc_type), intent(in) :: desc_data
@ -220,9 +220,10 @@ contains
type(psb_d_vect_type),intent(inout) :: x
type(psb_d_vect_type),intent(inout) :: y
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
type(psb_d_vect_type),intent(inout) :: wv(:)
integer, intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu

5
mlprec/mld_d_umf_solver.F90
Unescape Escape View File

@ -215,7 +215,7 @@ contains
end subroutine d_umf_solver_apply
subroutine d_umf_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
implicit none
type(psb_desc_type), intent(in) :: desc_data
@ -223,8 +223,9 @@ contains
type(psb_d_vect_type),intent(inout) :: x
type(psb_d_vect_type),intent(inout) :: y
real(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
character(len=1),intent(in) :: trans
real(psb_dpk_),target, intent(inout) :: work(:)
type(psb_d_vect_type),intent(inout) :: wv(:)
integer, intent(out) :: info
character, intent(in), optional :: init
type(psb_d_vect_type),intent(inout), optional :: initu

17
mlprec/mld_s_as_smoother.f90
Unescape Escape View File

@ -91,6 +91,7 @@ module mld_s_as_smoother
procedure, pass(sm) :: sizeof => s_as_smoother_sizeof
procedure, pass(sm) :: default => s_as_smoother_default
procedure, pass(sm) :: get_nzeros => s_as_smoother_get_nzeros
procedure, pass(sm) :: get_wrksz => s_as_smoother_get_wrksize
procedure, nopass :: get_fmt => s_as_smoother_get_fmt
procedure, nopass :: get_id => s_as_smoother_get_id
end type mld_s_as_smoother_type
@ -98,7 +99,8 @@ module mld_s_as_smoother
private :: s_as_smoother_descr, s_as_smoother_sizeof, &
& s_as_smoother_default, s_as_smoother_get_nzeros, &
& s_as_smoother_get_fmt, s_as_smoother_get_id
& s_as_smoother_get_fmt, s_as_smoother_get_id, &
& s_as_smoother_get_wrksize
character(len=6), parameter, private :: &
& restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/)
@ -179,7 +181,7 @@ module mld_s_as_smoother
interface
subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
& trans,sweeps,work,info,init,initu)
& trans,sweeps,work,wv,info,init,initu)
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
& psb_spk_, mld_s_as_smoother_type, psb_long_int_k_, &
& psb_desc_type, psb_ipk_
@ -192,6 +194,7 @@ module mld_s_as_smoother
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
@ -457,6 +460,16 @@ contains
end subroutine s_as_smoother_descr
function s_as_smoother_get_wrksize(sm) result(val)
implicit none
class(mld_s_as_smoother_type), intent(inout) :: sm
integer(psb_ipk_) :: val
val = 3
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
end function s_as_smoother_get_wrksize
function s_as_smoother_get_fmt() result(val)
implicit none
character(len=32) :: val

20
mlprec/mld_s_base_smoother_mod.f90
Unescape Escape View File

@ -92,6 +92,10 @@ module mld_s_base_smoother_mod
! check - Sanity checks.
! sizeof - Total memory occupation in bytes
! get_nzeros - Number of nonzeros
! stringval - convert string to val for internal parms
! get_fmt - short string descriptor
! get_id - numeric id descriptro
! get_wrksz - How many workspace vector does apply_vect need
!
!
!
@ -119,6 +123,7 @@ module mld_s_base_smoother_mod
procedure, pass(sm) :: descr => mld_s_base_smoother_descr
procedure, pass(sm) :: sizeof => s_base_smoother_sizeof
procedure, pass(sm) :: get_nzeros => s_base_smoother_get_nzeros
procedure, pass(sm) :: get_wrksz => s_base_smoother_get_wrksize
procedure, nopass :: stringval => mld_stringval
procedure, nopass :: get_fmt => s_base_smoother_get_fmt
procedure, nopass :: get_id => s_base_smoother_get_id
@ -127,7 +132,7 @@ module mld_s_base_smoother_mod
private :: s_base_smoother_sizeof, s_base_smoother_get_fmt, &
& s_base_smoother_default, s_base_smoother_get_nzeros, &
& s_base_smoother_get_id
& s_base_smoother_get_id, s_base_smoother_get_wrksize
@ -153,7 +158,7 @@ module mld_s_base_smoother_mod
interface
subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
& trans,sweeps,work,info,init,initu)
& trans,sweeps,work,wv,info,init,initu)
import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
& psb_s_vect_type, psb_s_base_vect_type, psb_spk_, &
& mld_s_base_smoother_type, psb_ipk_
@ -165,6 +170,7 @@ module mld_s_base_smoother_mod
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
@ -386,6 +392,16 @@ contains
return
end subroutine s_base_smoother_default
function s_base_smoother_get_wrksize(sm) result(val)
implicit none
class(mld_s_base_smoother_type), intent(inout) :: sm
integer(psb_ipk_) :: val
val = 0
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
end function s_base_smoother_get_wrksize
function s_base_smoother_get_fmt() result(val)
implicit none
character(len=32) :: val

18
mlprec/mld_s_base_solver_mod.f90
Unescape Escape View File

@ -78,7 +78,10 @@ module mld_s_base_solver_mod
! check - Sanity checks.
! sizeof - Total memory occupation in bytes
! get_nzeros - Number of nonzeros
!
! stringval - convert string to val for internal parms
! get_fmt - short string descriptor
! get_id - numeric id descriptro
! get_wrksz - How many workspace vector does apply_vect need
!
!
@ -104,6 +107,7 @@ module mld_s_base_solver_mod
procedure, pass(sv) :: descr => mld_s_base_solver_descr
procedure, pass(sv) :: sizeof => s_base_solver_sizeof
procedure, pass(sv) :: get_nzeros => s_base_solver_get_nzeros
procedure, nopass :: get_wrksz => s_base_solver_get_wrksize
procedure, nopass :: stringval => mld_stringval
procedure, nopass :: get_fmt => s_base_solver_get_fmt
procedure, nopass :: get_id => s_base_solver_get_id
@ -112,7 +116,8 @@ module mld_s_base_solver_mod
private :: s_base_solver_sizeof, s_base_solver_default,&
& s_base_solver_get_nzeros, s_base_solver_get_fmt, &
& s_base_solver_is_iterative, s_base_solver_get_id
& s_base_solver_is_iterative, s_base_solver_get_id, &
& s_base_solver_get_wrksize
interface
@ -138,7 +143,7 @@ module mld_s_base_solver_mod
interface
subroutine mld_s_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
& psb_s_vect_type, psb_s_base_vect_type, psb_spk_, &
& mld_s_base_solver_type, psb_ipk_
@ -150,6 +155,7 @@ module mld_s_base_solver_mod
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
@ -411,5 +417,11 @@ contains
val = mld_f_none_
end function s_base_solver_get_id
function s_base_solver_get_wrksize() result(val)
implicit none
integer(psb_ipk_) :: val
val = 0
end function s_base_solver_get_wrksize
end module mld_s_base_solver_mod

3
mlprec/mld_s_diag_solver.f90
Unescape Escape View File

@ -76,7 +76,7 @@ module mld_s_diag_solver
interface
subroutine mld_s_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
& psb_s_vect_type, psb_s_base_vect_type, psb_spk_, &
& mld_s_diag_solver_type, psb_ipk_
@ -87,6 +87,7 @@ module mld_s_diag_solver
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu

16
mlprec/mld_s_gs_solver.f90
Unescape Escape View File

@ -77,6 +77,7 @@ module mld_s_gs_solver
procedure, pass(sv) :: default => s_gs_solver_default
procedure, pass(sv) :: sizeof => s_gs_solver_sizeof
procedure, pass(sv) :: get_nzeros => s_gs_solver_get_nzeros
procedure, nopass :: get_wrksz => s_gs_solver_get_wrksize
procedure, nopass :: get_fmt => s_gs_solver_get_fmt
procedure, nopass :: get_id => s_gs_solver_get_id
procedure, nopass :: is_iterative => s_gs_solver_is_iterative
@ -102,11 +103,11 @@ module mld_s_gs_solver
& s_gs_solver_get_fmt, s_gs_solver_check,&
& s_gs_solver_is_iterative, &
& s_bwgs_solver_get_fmt, s_bwgs_solver_descr, &
& s_gs_solver_get_id, s_bwgs_solver_get_id
& s_gs_solver_get_id, s_bwgs_solver_get_id, s_gs_solver_get_wrksize
interface
subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, mld_s_gs_solver_type, psb_s_vect_type, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_
implicit none
@ -117,12 +118,13 @@ module mld_s_gs_solver
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
end subroutine mld_s_gs_solver_apply_vect
subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, mld_s_bwgs_solver_type, psb_s_vect_type, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_
implicit none
@ -133,6 +135,7 @@ module mld_s_gs_solver
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
@ -642,4 +645,11 @@ contains
val = mld_bwgs_
end function s_bwgs_solver_get_id
function s_gs_solver_get_wrksize() result(val)
implicit none
integer(psb_ipk_) :: val
val = 2
end function s_gs_solver_get_wrksize
end module mld_s_gs_solver

3
mlprec/mld_s_id_solver.f90
Unescape Escape View File

@ -64,7 +64,7 @@ module mld_s_id_solver
interface
subroutine mld_s_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
& psb_s_vect_type, psb_s_base_vect_type, psb_spk_, &
& mld_s_id_solver_type, psb_ipk_
@ -75,6 +75,7 @@ module mld_s_id_solver
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu

14
mlprec/mld_s_ilu_solver.f90
Unescape Escape View File

@ -85,6 +85,7 @@ module mld_s_ilu_solver
procedure, pass(sv) :: default => s_ilu_solver_default
procedure, pass(sv) :: sizeof => s_ilu_solver_sizeof
procedure, pass(sv) :: get_nzeros => s_ilu_solver_get_nzeros
procedure, nopass :: get_wrksz => s_ilu_solver_get_wrksize
procedure, nopass :: get_fmt => s_ilu_solver_get_fmt
procedure, nopass :: get_id => s_ilu_solver_get_id
end type mld_s_ilu_solver_type
@ -96,12 +97,13 @@ module mld_s_ilu_solver
& s_ilu_solver_descr, s_ilu_solver_sizeof, &
& s_ilu_solver_default, s_ilu_solver_dmp, &
& s_ilu_solver_apply_vect, s_ilu_solver_get_nzeros, &
& s_ilu_solver_get_fmt, s_ilu_solver_check, s_ilu_solver_get_id
& s_ilu_solver_get_fmt, s_ilu_solver_check, &
& s_ilu_solver_get_id, s_ilu_solver_get_wrksize
interface
subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, mld_s_ilu_solver_type, psb_s_vect_type, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_
implicit none
@ -112,6 +114,7 @@ module mld_s_ilu_solver
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
@ -554,5 +557,12 @@ contains
val = mld_ilu_n_
end function s_ilu_solver_get_id
function s_ilu_solver_get_wrksize() result(val)
implicit none
integer(psb_ipk_) :: val
val = 2
end function s_ilu_solver_get_wrksize
end module mld_s_ilu_solver

3
mlprec/mld_s_inner_mod.f90
Unescape Escape View File

@ -48,7 +48,8 @@ module mld_s_inner_mod
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_i_base_vect_type, &
& psb_spk_, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_, &
& psb_s_vect_type
use mld_s_prec_type, only : mld_sprec_type, mld_sml_parms, mld_s_onelev_type
use mld_s_prec_type, only : mld_sprec_type, mld_sml_parms, &
& mld_s_onelev_type, mld_smlprec_wrk_type
interface mld_mlprec_bld
subroutine mld_smlprec_bld(a,desc_a,prec,info, amold, vmold,imold)

17
mlprec/mld_s_jac_smoother.f90
Unescape Escape View File

@ -71,6 +71,7 @@ module mld_s_jac_smoother
procedure, pass(sm) :: descr => mld_s_jac_smoother_descr
procedure, pass(sm) :: sizeof => s_jac_smoother_sizeof
procedure, pass(sm) :: get_nzeros => s_jac_smoother_get_nzeros
procedure, pass(sm) :: get_wrksz => s_jac_smoother_get_wrksize
procedure, nopass :: get_fmt => s_jac_smoother_get_fmt
procedure, nopass :: get_id => s_jac_smoother_get_id
end type mld_s_jac_smoother_type
@ -78,12 +79,13 @@ module mld_s_jac_smoother
private :: s_jac_smoother_free, s_jac_smoother_descr, &
& s_jac_smoother_sizeof, s_jac_smoother_get_nzeros, &
& s_jac_smoother_get_fmt, s_jac_smoother_get_id
& s_jac_smoother_get_fmt, s_jac_smoother_get_id, &
& s_jac_smoother_get_wrksize
interface
subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info,init,initu)
& sweeps,work,wv,info,init,initu)
import :: psb_desc_type, mld_s_jac_smoother_type, psb_s_vect_type, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,&
& psb_ipk_
@ -96,6 +98,7 @@ module mld_s_jac_smoother
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu
@ -252,6 +255,16 @@ contains
return
end function s_jac_smoother_get_nzeros
function s_jac_smoother_get_wrksize(sm) result(val)
implicit none
class(mld_s_jac_smoother_type), intent(inout) :: sm
integer(psb_ipk_) :: val
val = 2
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
end function s_jac_smoother_get_wrksize
function s_jac_smoother_get_fmt() result(val)
implicit none
character(len=32) :: val

5
mlprec/mld_s_mumps_solver.F90
Unescape Escape View File

@ -103,7 +103,7 @@ module mld_s_mumps_solver
interface
subroutine s_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, mld_s_mumps_solver_type, psb_s_vect_type, psb_dpk_, psb_spk_, &
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_
implicit none
@ -112,8 +112,9 @@ module mld_s_mumps_solver
type(psb_s_vect_type),intent(inout) :: x
type(psb_s_vect_type),intent(inout) :: y
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
type(psb_s_vect_type),intent(inout) :: wv(:)
integer, intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu

209
mlprec/mld_s_onelev_mod.f90
Unescape Escape View File

@ -117,11 +117,27 @@ module mld_s_onelev_mod
! check - Sanity checks.
! sizeof - Total memory occupation in bytes
! get_nzeros - Number of nonzeros
! get_wrksz - How many workspace vector does apply_vect need
!
!
!
type mld_smlprec_wrk_type
real(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:)
type(psb_s_vect_type) :: vtx, vty, vx2l, vy2l
integer(psb_ipk_) :: wvsz = 0
type(psb_s_vect_type), allocatable :: wv(:)
contains
procedure, pass(wk) :: alloc => s_wrk_alloc
procedure, pass(wk) :: free => s_wrk_free
procedure, pass(wk) :: clone => s_wrk_clone
procedure, pass(wk) :: move_alloc => s_wrk_move_alloc
end type mld_smlprec_wrk_type
private :: s_wrk_alloc, s_wrk_free, &
& s_wrk_clone, s_wrk_move_alloc
type mld_s_onelev_type
class(mld_s_base_smoother_type), allocatable :: sm, sm2a
class(mld_s_base_smoother_type), pointer :: sm2 => null()
class(mld_smlprec_wrk_type), allocatable :: wrk
type(mld_sml_parms) :: parms
type(psb_sspmat_type) :: ac
integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot
@ -153,6 +169,9 @@ module mld_s_onelev_mod
& cseti, csetr, csetc, setsm, setsv
procedure, pass(lv) :: sizeof => s_base_onelev_sizeof
procedure, pass(lv) :: get_nzeros => s_base_onelev_get_nzeros
procedure, pass(lv) :: get_wrksz => s_base_onelev_get_wrksize
procedure, pass(lv) :: allocate_wrk => s_base_onelev_allocate_wrk
procedure, pass(lv) :: free_wrk => s_base_onelev_free_wrk
procedure, nopass :: stringval => mld_stringval
procedure, pass(lv) :: move_alloc => s_base_onelev_move_alloc
end type mld_s_onelev_type
@ -164,7 +183,9 @@ module mld_s_onelev_mod
private :: s_base_onelev_default, s_base_onelev_sizeof, &
& s_base_onelev_nullify, s_base_onelev_get_nzeros, &
& s_base_onelev_clone, s_base_onelev_move_alloc
& s_base_onelev_clone, s_base_onelev_move_alloc, &
& s_base_onelev_get_wrksize, s_base_onelev_allocate_wrk, &
& s_base_onelev_free_wrk
@ -498,7 +519,6 @@ contains
end subroutine s_base_onelev_clone
subroutine s_base_onelev_move_alloc(lv, b,info)
use psb_base_mod
implicit none
@ -527,4 +547,187 @@ contains
end subroutine s_base_onelev_move_alloc
function s_base_onelev_get_wrksize(lv) result(val)
implicit none
class(mld_s_onelev_type), intent(inout) :: lv
integer(psb_ipk_) :: val
val = 0
! SM and SM2A can share work vectors
if (allocated(lv%sm)) val = val + lv%sm%get_wrksz()
if (allocated(lv%sm2a)) val = max(val,lv%sm2a%get_wrksz())
!
! Now for the ML application itself
!
! VTX/VTY/VX2L/VY2L are stored explicitly
!
!
! additions for specific ML/cycles
!
select case(lv%parms%ml_cycle)
case(mld_add_ml_,mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_)
! We're good
case(mld_kcycle_ml_, mld_kcyclesym_ml_)
!
! We need 7 in inneritkcycle.
! Can we reuse vtx?
!
val = val + 7
case default
! Need a better error signaling ?
val = -1
end select
end function s_base_onelev_get_wrksize
subroutine s_base_onelev_allocate_wrk(lv,info,vmold)
use psb_base_mod
implicit none
class(mld_s_onelev_type), target, intent(inout) :: lv
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type), intent(in), optional :: vmold
!
integer(psb_ipk_) :: nwv, i
info = psb_success_
nwv = lv%get_wrksz()
if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info)
if (info == 0) call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold)
end subroutine s_base_onelev_allocate_wrk
subroutine s_base_onelev_free_wrk(lv,info)
use psb_base_mod
implicit none
class(mld_s_onelev_type), target, intent(inout) :: lv
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: nwv,i
info = psb_success_
if (allocated(lv%wrk)) then
call lv%wrk%free(info)
if (info == 0) deallocate(lv%wrk,stat=info)
end if
end subroutine s_base_onelev_free_wrk
subroutine s_wrk_alloc(wk,nwv,desc,info,vmold)
use psb_base_mod
Implicit None
! Arguments
class(mld_smlprec_wrk_type), target, intent(inout) :: wk
integer(psb_ipk_), intent(in) :: nwv
type(psb_desc_type), intent(in) :: desc
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type), intent(in), optional :: vmold
!
integer(psb_ipk_) :: i
info = psb_success_
call wk%free(info)
call psb_geasb(wk%vx2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vy2l,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vtx,desc,info,&
& scratch=.true.,mold=vmold)
call psb_geasb(wk%vty,desc,info,&
& scratch=.true.,mold=vmold)
allocate(wk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(wk%wv(i),desc,info,&
& scratch=.true.,mold=vmold)
end do
end subroutine s_wrk_alloc
subroutine s_wrk_free(wk,info)
Implicit None
! Arguments
class(mld_smlprec_wrk_type), target, intent(inout) :: wk
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: i
info = psb_success_
if (allocated(wk%tx)) deallocate(wk%tx, stat=info)
if (allocated(wk%ty)) deallocate(wk%ty, stat=info)
if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info)
if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info)
call wk%vtx%free(info)
call wk%vty%free(info)
call wk%vx2l%free(info)
call wk%vy2l%free(info)
if (allocated(wk%wv)) then
do i=1,size(wk%wv)
call wk%wv(i)%free(info)
end do
deallocate(wk%wv, stat=info)
end if
end subroutine s_wrk_free
subroutine s_wrk_clone(wk,wkout,info)
use psb_base_mod
Implicit None
! Arguments
class(mld_smlprec_wrk_type), target, intent(inout) :: wk
class(mld_smlprec_wrk_type), target, intent(inout) :: wkout
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: i
info = psb_success_
call psb_safe_ab_cpy(wk%tx,wkout%tx,info)
call psb_safe_ab_cpy(wk%ty,wkout%ty,info)
call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info)
call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info)
call wk%vtx%clone(wkout%vtx,info)
call wk%vty%clone(wkout%vty,info)
call wk%vx2l%clone(wkout%vx2l,info)
call wk%vy2l%clone(wkout%vy2l,info)
if (allocated(wkout%wv)) then
do i=1,size(wkout%wv)
call wkout%wv(i)%free(info)
end do
deallocate( wkout%wv)
end if
allocate(wkout%wv(size(wk%wv)),stat=info)
do i=1,size(wk%wv)
call wk%wv(i)%clone(wkout%wv(i),info)
end do
return
end subroutine s_wrk_clone
subroutine s_wrk_move_alloc(wk, b,info)
implicit none
class(mld_smlprec_wrk_type), target, intent(inout) :: wk, b
integer(psb_ipk_), intent(out) :: info
call b%free(info)
call move_alloc(wk%tx,b%tx)
call move_alloc(wk%ty,b%ty)
call move_alloc(wk%x2l,b%x2l)
call move_alloc(wk%y2l,b%y2l)
!
! Should define V%move_alloc....
call move_alloc(wk%vtx%v,b%vtx%v)
call move_alloc(wk%vty%v,b%vty%v)
call move_alloc(wk%vx2l%v,b%vx2l%v)
call move_alloc(wk%vy2l%v,b%vy2l%v)
call move_alloc(wk%wv,b%wv)
end subroutine s_wrk_move_alloc
end module mld_s_onelev_mod

83
mlprec/mld_s_prec_type.f90
Unescape Escape View File

@ -80,7 +80,8 @@ module mld_s_prec_type
! order, with level 0 being the id of the coarsest level.
!
!
integer, parameter, private :: wv_size_=4
type, extends(psb_sprec_type) :: mld_sprec_type
integer(psb_ipk_) :: ictxt
!
@ -116,6 +117,8 @@ module mld_s_prec_type
procedure, pass(prec) :: dump => mld_s_dump
procedure, pass(prec) :: clone => mld_s_clone
procedure, pass(prec) :: free => mld_s_prec_free
procedure, pass(prec) :: allocate_wrk => mld_s_allocate_wrk
procedure, pass(prec) :: free_wrk => mld_s_free_wrk
procedure, pass(prec) :: get_complexity => mld_s_get_compl
procedure, pass(prec) :: cmp_complexity => mld_s_cmp_compl
procedure, pass(prec) :: get_nlevs => mld_s_get_nlevs
@ -552,7 +555,7 @@ contains
call psb_erractionsave(err_act)
me=-1
call prec%free_wrk(info)
if (allocated(prec%precv)) then
do i=1,size(prec%precv)
call prec%precv(i)%free(info)
@ -778,6 +781,9 @@ contains
end if
end do
end if
if (allocated(prec%precv(1)%wrk)) &
& call pout%allocate_wrk(info,vmold=prec%precv(1)%wrk%vx2l%v)
class default
write(0,*) 'Error: wrong out type'
info = psb_err_invalid_input_
@ -811,10 +817,81 @@ contains
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
else
write(0,*) 'Warning: PREC%move_alloc onto different type?'
info = psb_err_internal_error_
end if
end subroutine s_prec_move_alloc
subroutine mld_s_allocate_wrk(prec,info,vmold)
use psb_base_mod
implicit none
! Arguments
class(mld_sprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type), intent(in), optional :: vmold
! Local variables
integer(psb_ipk_) :: me,err_act,i,j,level,nlev, nc2l
character(len=20) :: name
if(psb_get_errstatus().ne.0) return
info=psb_success_
name = 'mld_s_allocate_wrk'
call psb_erractionsave(err_act)
nlev = size(prec%precv)
level = 1
do level = 1, nlev
call prec%precv(level)%allocate_wrk(info,vmold=vmold)
if (psb_errstatus_fatal()) then
nc2l = prec%precv(level)%base_desc%get_local_cols()
info=psb_err_alloc_request_
call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),&
& a_err='real(psb_spk_)')
goto 9999
end if
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_s_allocate_wrk
subroutine mld_s_free_wrk(prec,info)
use psb_base_mod
implicit none
! Arguments
class(mld_sprec_type), intent(inout) :: prec
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: me,err_act,i,j,level, nlev, nc2l
character(len=20) :: name
if(psb_get_errstatus().ne.0) return
info=psb_success_
name = 'mld_s_free_wrk'
call psb_erractionsave(err_act)
nlev = size(prec%precv)
do level = 1, nlev
call prec%precv(level)%free_wrk(info)
end do
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine mld_s_free_wrk
end module mld_s_prec_type

7
mlprec/mld_s_slu_solver.F90
Unescape Escape View File

@ -211,7 +211,7 @@ contains
end subroutine s_slu_solver_apply
subroutine s_slu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
use psb_base_mod
implicit none
type(psb_desc_type), intent(in) :: desc_data
@ -219,9 +219,10 @@ contains
type(psb_s_vect_type),intent(inout) :: x
type(psb_s_vect_type),intent(inout) :: y
real(psb_spk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
character(len=1),intent(in) :: trans
real(psb_spk_),target, intent(inout) :: work(:)
integer, intent(out) :: info
type(psb_s_vect_type),intent(inout) :: wv(:)
integer, intent(out) :: info
character, intent(in), optional :: init
type(psb_s_vect_type),intent(inout), optional :: initu

17
mlprec/mld_z_as_smoother.f90
Unescape Escape View File

@ -91,6 +91,7 @@ module mld_z_as_smoother
procedure, pass(sm) :: sizeof => z_as_smoother_sizeof
procedure, pass(sm) :: default => z_as_smoother_default
procedure, pass(sm) :: get_nzeros => z_as_smoother_get_nzeros
procedure, pass(sm) :: get_wrksz => z_as_smoother_get_wrksize
procedure, nopass :: get_fmt => z_as_smoother_get_fmt
procedure, nopass :: get_id => z_as_smoother_get_id
end type mld_z_as_smoother_type
@ -98,7 +99,8 @@ module mld_z_as_smoother
private :: z_as_smoother_descr, z_as_smoother_sizeof, &
& z_as_smoother_default, z_as_smoother_get_nzeros, &
& z_as_smoother_get_fmt, z_as_smoother_get_id
& z_as_smoother_get_fmt, z_as_smoother_get_id, &
& z_as_smoother_get_wrksize
character(len=6), parameter, private :: &
& restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/)
@ -179,7 +181,7 @@ module mld_z_as_smoother
interface
subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
& trans,sweeps,work,info,init,initu)
& trans,sweeps,work,wv,info,init,initu)
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
& psb_dpk_, mld_z_as_smoother_type, psb_long_int_k_, &
& psb_desc_type, psb_ipk_
@ -192,6 +194,7 @@ module mld_z_as_smoother
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu
@ -457,6 +460,16 @@ contains
end subroutine z_as_smoother_descr
function z_as_smoother_get_wrksize(sm) result(val)
implicit none
class(mld_z_as_smoother_type), intent(inout) :: sm
integer(psb_ipk_) :: val
val = 3
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
end function z_as_smoother_get_wrksize
function z_as_smoother_get_fmt() result(val)
implicit none
character(len=32) :: val

20
mlprec/mld_z_base_smoother_mod.f90
Unescape Escape View File

@ -92,6 +92,10 @@ module mld_z_base_smoother_mod
! check - Sanity checks.
! sizeof - Total memory occupation in bytes
! get_nzeros - Number of nonzeros
! stringval - convert string to val for internal parms
! get_fmt - short string descriptor
! get_id - numeric id descriptro
! get_wrksz - How many workspace vector does apply_vect need
!
!
!
@ -119,6 +123,7 @@ module mld_z_base_smoother_mod
procedure, pass(sm) :: descr => mld_z_base_smoother_descr
procedure, pass(sm) :: sizeof => z_base_smoother_sizeof
procedure, pass(sm) :: get_nzeros => z_base_smoother_get_nzeros
procedure, pass(sm) :: get_wrksz => z_base_smoother_get_wrksize
procedure, nopass :: stringval => mld_stringval
procedure, nopass :: get_fmt => z_base_smoother_get_fmt
procedure, nopass :: get_id => z_base_smoother_get_id
@ -127,7 +132,7 @@ module mld_z_base_smoother_mod
private :: z_base_smoother_sizeof, z_base_smoother_get_fmt, &
& z_base_smoother_default, z_base_smoother_get_nzeros, &
& z_base_smoother_get_id
& z_base_smoother_get_id, z_base_smoother_get_wrksize
@ -153,7 +158,7 @@ module mld_z_base_smoother_mod
interface
subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,&
& trans,sweeps,work,info,init,initu)
& trans,sweeps,work,wv,info,init,initu)
import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
& psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, &
& mld_z_base_smoother_type, psb_ipk_
@ -165,6 +170,7 @@ module mld_z_base_smoother_mod
character(len=1),intent(in) :: trans
integer(psb_ipk_), intent(in) :: sweeps
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu
@ -386,6 +392,16 @@ contains
return
end subroutine z_base_smoother_default
function z_base_smoother_get_wrksize(sm) result(val)
implicit none
class(mld_z_base_smoother_type), intent(inout) :: sm
integer(psb_ipk_) :: val
val = 0
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
end function z_base_smoother_get_wrksize
function z_base_smoother_get_fmt() result(val)
implicit none
character(len=32) :: val

18
mlprec/mld_z_base_solver_mod.f90
Unescape Escape View File

@ -78,7 +78,10 @@ module mld_z_base_solver_mod
! check - Sanity checks.
! sizeof - Total memory occupation in bytes
! get_nzeros - Number of nonzeros
!
! stringval - convert string to val for internal parms
! get_fmt - short string descriptor
! get_id - numeric id descriptro
! get_wrksz - How many workspace vector does apply_vect need
!
!
@ -104,6 +107,7 @@ module mld_z_base_solver_mod
procedure, pass(sv) :: descr => mld_z_base_solver_descr
procedure, pass(sv) :: sizeof => z_base_solver_sizeof
procedure, pass(sv) :: get_nzeros => z_base_solver_get_nzeros
procedure, nopass :: get_wrksz => z_base_solver_get_wrksize
procedure, nopass :: stringval => mld_stringval
procedure, nopass :: get_fmt => z_base_solver_get_fmt
procedure, nopass :: get_id => z_base_solver_get_id
@ -112,7 +116,8 @@ module mld_z_base_solver_mod
private :: z_base_solver_sizeof, z_base_solver_default,&
& z_base_solver_get_nzeros, z_base_solver_get_fmt, &
& z_base_solver_is_iterative, z_base_solver_get_id
& z_base_solver_is_iterative, z_base_solver_get_id, &
& z_base_solver_get_wrksize
interface
@ -138,7 +143,7 @@ module mld_z_base_solver_mod
interface
subroutine mld_z_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
& psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, &
& mld_z_base_solver_type, psb_ipk_
@ -150,6 +155,7 @@ module mld_z_base_solver_mod
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu
@ -411,5 +417,11 @@ contains
val = mld_f_none_
end function z_base_solver_get_id
function z_base_solver_get_wrksize() result(val)
implicit none
integer(psb_ipk_) :: val
val = 0
end function z_base_solver_get_wrksize
end module mld_z_base_solver_mod

3
mlprec/mld_z_diag_solver.f90
Unescape Escape View File

@ -76,7 +76,7 @@ module mld_z_diag_solver
interface
subroutine mld_z_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
& psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, &
& mld_z_diag_solver_type, psb_ipk_
@ -87,6 +87,7 @@ module mld_z_diag_solver
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu

16
mlprec/mld_z_gs_solver.f90
Unescape Escape View File

@ -77,6 +77,7 @@ module mld_z_gs_solver
procedure, pass(sv) :: default => z_gs_solver_default
procedure, pass(sv) :: sizeof => z_gs_solver_sizeof
procedure, pass(sv) :: get_nzeros => z_gs_solver_get_nzeros
procedure, nopass :: get_wrksz => z_gs_solver_get_wrksize
procedure, nopass :: get_fmt => z_gs_solver_get_fmt
procedure, nopass :: get_id => z_gs_solver_get_id
procedure, nopass :: is_iterative => z_gs_solver_is_iterative
@ -102,11 +103,11 @@ module mld_z_gs_solver
& z_gs_solver_get_fmt, z_gs_solver_check,&
& z_gs_solver_is_iterative, &
& z_bwgs_solver_get_fmt, z_bwgs_solver_descr, &
& z_gs_solver_get_id, z_bwgs_solver_get_id
& z_gs_solver_get_id, z_bwgs_solver_get_id, z_gs_solver_get_wrksize
interface
subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, mld_z_gs_solver_type, psb_z_vect_type, psb_dpk_, &
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_
implicit none
@ -117,12 +118,13 @@ module mld_z_gs_solver
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu
end subroutine mld_z_gs_solver_apply_vect
subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, mld_z_bwgs_solver_type, psb_z_vect_type, psb_dpk_, &
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_
implicit none
@ -133,6 +135,7 @@ module mld_z_gs_solver
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu
@ -642,4 +645,11 @@ contains
val = mld_bwgs_
end function z_bwgs_solver_get_id
function z_gs_solver_get_wrksize() result(val)
implicit none
integer(psb_ipk_) :: val
val = 2
end function z_gs_solver_get_wrksize
end module mld_z_gs_solver

3
mlprec/mld_z_id_solver.f90
Unescape Escape View File

@ -64,7 +64,7 @@ module mld_z_id_solver
interface
subroutine mld_z_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
& trans,work,info,init,initu)
& trans,work,wv,info,init,initu)
import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
& psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, &
& mld_z_id_solver_type, psb_ipk_
@ -75,6 +75,7 @@ module mld_z_id_solver
complex(psb_dpk_),intent(in) :: alpha,beta
character(len=1),intent(in) :: trans
complex(psb_dpk_),target, intent(inout) :: work(:)
type(psb_z_vect_type),intent(inout) :: wv(:)
integer(psb_ipk_), intent(out) :: info
character, intent(in), optional :: init
type(psb_z_vect_type),intent(inout), optional :: initu

Some files were not shown because too many files have changed in this diff Show More

Write Preview
Loading…
Cancel
Save