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

Fixed allocte_wrk & free_wrk for WV allocation.

Browse Source 
Modified interface of smoothers to use WV.
Initial tests.
Added WV to calls to MAP_X2Y & MAP_Y2X.
stopcriterion
Salvatore Filippone 7 years ago
parent 6f9a3c10d2
commit 823db4f943
40 changed files with 1212 additions and 1028 deletions
Show Stats Download Patch File Download Diff File

68
mlprec/impl/mld_cmlprec_aply.f90
Unescape Escape View File

@ -255,7 +255,8 @@ subroutine mld_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv(:))
!
! At first iteration we must use the input BETA
!
@ -482,7 +483,8 @@ contains
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
if (allocated(p%precv(level)%sm2a)) then
call psb_geaxpby(cone,&
@ -494,12 +496,12 @@ contains
call p%precv(level)%sm%apply(cone,&
& vy2l,czero,vty,&
& base_desc, trans,&
& ione,work,info,init='Z')
& ione,work,wv,info,init='Z')
call p%precv(level)%sm2a%apply(cone,&
& vty,czero,vy2l,&
& base_desc, trans,&
& ione,work,info,init='Z')
& ione,work,wv,info,init='Z')
end do
else
@ -507,7 +509,7 @@ contains
call p%precv(level)%sm%apply(cone,&
& vx2l,czero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -519,7 +521,8 @@ contains
! Apply the restriction
call psb_map_X2Y(cone,vx2l,&
& czero,p%precv(level+1)%wrk%vx2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
@ -538,7 +541,8 @@ contains
!
call psb_map_Y2X(cone,p%precv(level+1)%wrk%vy2l,&
& cone,vy2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
@ -605,7 +609,8 @@ contains
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
if (level < nlev) then
!
! Apply the first smoother
@ -618,13 +623,13 @@ contains
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vx2l,czero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
& vx2l,czero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@ -651,7 +656,8 @@ contains
end if
call psb_map_X2Y(cone,vty,&
& czero,p%precv(level+1)%wrk%vx2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
@ -661,7 +667,8 @@ contains
! Shortcut: just transfer x2l.
call psb_map_X2Y(cone,vx2l,&
& czero,p%precv(level+1)%wrk%vx2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
@ -676,7 +683,8 @@ contains
!
call psb_map_Y2X(cone,p%precv(level+1)%wrk%vy2l,&
& cone,vy2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
@ -693,7 +701,8 @@ contains
& base_desc,info,work=work,trans=trans)
if (info == psb_success_) call psb_map_X2Y(cone,vty,&
& czero,p%precv(level+1)%wrk%vx2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during W-cycle restriction')
@ -704,7 +713,8 @@ contains
if (info == psb_success_) call psb_map_Y2X(cone,p%precv(level+1)%wrk%vy2l,&
& cone,vy2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -737,13 +747,13 @@ contains
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
& vty,cone,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vty,cone,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@ -760,7 +770,7 @@ contains
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vx2l,czero,vy2l,&
& base_desc, trans,&
& sweeps,work,info)
& sweeps,work,wv,info)
else
@ -836,7 +846,8 @@ contains
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
if (level == nlev) then
!
! Apply smoother
@ -845,7 +856,7 @@ contains
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vx2l,czero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else if (level < nlev) then
@ -854,13 +865,13 @@ contains
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vx2l,czero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
& vx2l,czero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@ -890,7 +901,8 @@ contains
! Apply the restriction
call psb_map_X2Y(cone,vty,&
& czero,p%precv(level + 1)%wrk%vx2l,&
& p%precv(level + 1)%map,info,work=work)
& p%precv(level + 1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -925,7 +937,8 @@ contains
!
call psb_map_Y2X(cone,p%precv(level+1)%wrk%vy2l,&
& cone,vy2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -955,13 +968,13 @@ contains
if (info == psb_success_) call p%precv(level)%sm2%apply(cone,&
& vty,cone,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(cone,&
& vty,cone,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@ -1014,7 +1027,8 @@ contains
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
!Assemble rhs, w, v, v1, x

49
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%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)
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.
!
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.)
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)
& 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,6 +500,11 @@ subroutine mld_cprecaply1_vect(prec,x,desc_data,info,trans,work)
call psb_errpush(info,name)
goto 9999
end if
do_alloc_wrk = .not.allocated(prec%wrk)
if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
associate(ww => prec%precv(1)%wrk%vtx, wv => prec%precv(1)%wrk%wv)
call psb_geasb(ww,desc_data,info,mold=x%v,scratch=.true.)
if (size(prec%precv) >1) then
!
@ -524,16 +531,16 @@ subroutine mld_cprecaply1_vect(prec,x,desc_data,info,trans,work)
case ('N')
do k=1, nswps
call prec%precv(1)%sm%apply(cone,x,czero,ww,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(cone,ww,czero,x,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,x,czero,ww,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
call prec%precv(1)%sm%apply(cone,ww,czero,x,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
end do
case default
info = psb_err_from_subroutine_
@ -543,7 +550,7 @@ subroutine mld_cprecaply1_vect(prec,x,desc_data,info,trans,work)
else
call prec%precv(1)%sm%apply(cone,x,czero,ww,desc_data,trans_,&
& nswps, work_,info)
& nswps, work_,wv,info)
if (info == 0) call psb_geaxpby(cone,ww,czero,x,desc_data,info)
end if
else
@ -553,8 +560,8 @@ subroutine mld_cprecaply1_vect(prec,x,desc_data,info,trans,work)
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
endif
if (info == 0) call psb_gefree(ww,desc_data,info)
end associate
!!$ if (info == 0) call psb_gefree(ww,desc_data,info)
! If the original distribution has an overlap we should fix that.
call psb_halo(x,desc_data,info,data=psb_comm_mov_)

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_

68
mlprec/impl/mld_dmlprec_aply.f90
Unescape Escape View File

@ -255,7 +255,8 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv(:))
!
! At first iteration we must use the input BETA
!
@ -482,7 +483,8 @@ contains
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
if (allocated(p%precv(level)%sm2a)) then
call psb_geaxpby(done,&
@ -494,12 +496,12 @@ contains
call p%precv(level)%sm%apply(done,&
& vy2l,dzero,vty,&
& base_desc, trans,&
& ione,work,info,init='Z')
& ione,work,wv,info,init='Z')
call p%precv(level)%sm2a%apply(done,&
& vty,dzero,vy2l,&
& base_desc, trans,&
& ione,work,info,init='Z')
& ione,work,wv,info,init='Z')
end do
else
@ -507,7 +509,7 @@ contains
call p%precv(level)%sm%apply(done,&
& vx2l,dzero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -519,7 +521,8 @@ contains
! Apply the restriction
call psb_map_X2Y(done,vx2l,&
& dzero,p%precv(level+1)%wrk%vx2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
@ -538,7 +541,8 @@ contains
!
call psb_map_Y2X(done,p%precv(level+1)%wrk%vy2l,&
& done,vy2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
@ -605,7 +609,8 @@ contains
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
if (level < nlev) then
!
! Apply the first smoother
@ -618,13 +623,13 @@ contains
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vx2l,dzero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
& vx2l,dzero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@ -651,7 +656,8 @@ contains
end if
call psb_map_X2Y(done,vty,&
& dzero,p%precv(level+1)%wrk%vx2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
@ -661,7 +667,8 @@ contains
! Shortcut: just transfer x2l.
call psb_map_X2Y(done,vx2l,&
& dzero,p%precv(level+1)%wrk%vx2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
@ -676,7 +683,8 @@ contains
!
call psb_map_Y2X(done,p%precv(level+1)%wrk%vy2l,&
& done,vy2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
@ -693,7 +701,8 @@ contains
& base_desc,info,work=work,trans=trans)
if (info == psb_success_) call psb_map_X2Y(done,vty,&
& dzero,p%precv(level+1)%wrk%vx2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during W-cycle restriction')
@ -704,7 +713,8 @@ contains
if (info == psb_success_) call psb_map_Y2X(done,p%precv(level+1)%wrk%vy2l,&
& done,vy2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -737,13 +747,13 @@ contains
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
& vty,done,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vty,done,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@ -760,7 +770,7 @@ contains
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vx2l,dzero,vy2l,&
& base_desc, trans,&
& sweeps,work,info)
& sweeps,work,wv,info)
else
@ -836,7 +846,8 @@ contains
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
if (level == nlev) then
!
! Apply smoother
@ -845,7 +856,7 @@ contains
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vx2l,dzero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else if (level < nlev) then
@ -854,13 +865,13 @@ contains
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vx2l,dzero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
& vx2l,dzero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@ -890,7 +901,8 @@ contains
! Apply the restriction
call psb_map_X2Y(done,vty,&
& dzero,p%precv(level + 1)%wrk%vx2l,&
& p%precv(level + 1)%map,info,work=work)
& p%precv(level + 1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -925,7 +937,8 @@ contains
!
call psb_map_Y2X(done,p%precv(level+1)%wrk%vy2l,&
& done,vy2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -955,13 +968,13 @@ contains
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
& vty,done,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
& vty,done,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@ -1014,7 +1027,8 @@ contains
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
!Assemble rhs, w, v, v1, x

49
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%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)
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.
!
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.)
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)
& 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,6 +500,11 @@ subroutine mld_dprecaply1_vect(prec,x,desc_data,info,trans,work)
call psb_errpush(info,name)
goto 9999
end if
do_alloc_wrk = .not.allocated(prec%wrk)
if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
associate(ww => prec%precv(1)%wrk%vtx, wv => prec%precv(1)%wrk%wv)
call psb_geasb(ww,desc_data,info,mold=x%v,scratch=.true.)
if (size(prec%precv) >1) then
!
@ -524,16 +531,16 @@ subroutine mld_dprecaply1_vect(prec,x,desc_data,info,trans,work)
case ('N')
do k=1, nswps
call prec%precv(1)%sm%apply(done,x,dzero,ww,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(done,ww,dzero,x,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,x,dzero,ww,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
call prec%precv(1)%sm%apply(done,ww,dzero,x,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
end do
case default
info = psb_err_from_subroutine_
@ -543,7 +550,7 @@ subroutine mld_dprecaply1_vect(prec,x,desc_data,info,trans,work)
else
call prec%precv(1)%sm%apply(done,x,dzero,ww,desc_data,trans_,&
& nswps, work_,info)
& nswps, work_,wv,info)
if (info == 0) call psb_geaxpby(done,ww,dzero,x,desc_data,info)
end if
else
@ -553,8 +560,8 @@ subroutine mld_dprecaply1_vect(prec,x,desc_data,info,trans,work)
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
endif
if (info == 0) call psb_gefree(ww,desc_data,info)
end associate
!!$ if (info == 0) call psb_gefree(ww,desc_data,info)
! If the original distribution has an overlap we should fix that.
call psb_halo(x,desc_data,info,data=psb_comm_mov_)

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_

68
mlprec/impl/mld_smlprec_aply.f90
Unescape Escape View File

@ -255,7 +255,8 @@ subroutine mld_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv(:))
!
! At first iteration we must use the input BETA
!
@ -482,7 +483,8 @@ contains
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
if (allocated(p%precv(level)%sm2a)) then
call psb_geaxpby(sone,&
@ -494,12 +496,12 @@ contains
call p%precv(level)%sm%apply(sone,&
& vy2l,szero,vty,&
& base_desc, trans,&
& ione,work,info,init='Z')
& ione,work,wv,info,init='Z')
call p%precv(level)%sm2a%apply(sone,&
& vty,szero,vy2l,&
& base_desc, trans,&
& ione,work,info,init='Z')
& ione,work,wv,info,init='Z')
end do
else
@ -507,7 +509,7 @@ contains
call p%precv(level)%sm%apply(sone,&
& vx2l,szero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -519,7 +521,8 @@ contains
! Apply the restriction
call psb_map_X2Y(sone,vx2l,&
& szero,p%precv(level+1)%wrk%vx2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
@ -538,7 +541,8 @@ contains
!
call psb_map_Y2X(sone,p%precv(level+1)%wrk%vy2l,&
& sone,vy2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
@ -605,7 +609,8 @@ contains
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
if (level < nlev) then
!
! Apply the first smoother
@ -618,13 +623,13 @@ contains
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vx2l,szero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
& vx2l,szero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@ -651,7 +656,8 @@ contains
end if
call psb_map_X2Y(sone,vty,&
& szero,p%precv(level+1)%wrk%vx2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
@ -661,7 +667,8 @@ contains
! Shortcut: just transfer x2l.
call psb_map_X2Y(sone,vx2l,&
& szero,p%precv(level+1)%wrk%vx2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
@ -676,7 +683,8 @@ contains
!
call psb_map_Y2X(sone,p%precv(level+1)%wrk%vy2l,&
& sone,vy2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
@ -693,7 +701,8 @@ contains
& base_desc,info,work=work,trans=trans)
if (info == psb_success_) call psb_map_X2Y(sone,vty,&
& szero,p%precv(level+1)%wrk%vx2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during W-cycle restriction')
@ -704,7 +713,8 @@ contains
if (info == psb_success_) call psb_map_Y2X(sone,p%precv(level+1)%wrk%vy2l,&
& sone,vy2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -737,13 +747,13 @@ contains
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
& vty,sone,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vty,sone,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@ -760,7 +770,7 @@ contains
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vx2l,szero,vy2l,&
& base_desc, trans,&
& sweeps,work,info)
& sweeps,work,wv,info)
else
@ -836,7 +846,8 @@ contains
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
if (level == nlev) then
!
! Apply smoother
@ -845,7 +856,7 @@ contains
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vx2l,szero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else if (level < nlev) then
@ -854,13 +865,13 @@ contains
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vx2l,szero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
& vx2l,szero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@ -890,7 +901,8 @@ contains
! Apply the restriction
call psb_map_X2Y(sone,vty,&
& szero,p%precv(level + 1)%wrk%vx2l,&
& p%precv(level + 1)%map,info,work=work)
& p%precv(level + 1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -925,7 +937,8 @@ contains
!
call psb_map_Y2X(sone,p%precv(level+1)%wrk%vy2l,&
& sone,vy2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -955,13 +968,13 @@ contains
if (info == psb_success_) call p%precv(level)%sm2%apply(sone,&
& vty,sone,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(sone,&
& vty,sone,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@ -1014,7 +1027,8 @@ contains
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
!Assemble rhs, w, v, v1, x

49
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%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)
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.
!
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.)
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)
& 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,6 +500,11 @@ subroutine mld_sprecaply1_vect(prec,x,desc_data,info,trans,work)
call psb_errpush(info,name)
goto 9999
end if
do_alloc_wrk = .not.allocated(prec%wrk)
if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
associate(ww => prec%precv(1)%wrk%vtx, wv => prec%precv(1)%wrk%wv)
call psb_geasb(ww,desc_data,info,mold=x%v,scratch=.true.)
if (size(prec%precv) >1) then
!
@ -524,16 +531,16 @@ subroutine mld_sprecaply1_vect(prec,x,desc_data,info,trans,work)
case ('N')
do k=1, nswps
call prec%precv(1)%sm%apply(sone,x,szero,ww,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(sone,ww,szero,x,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,x,szero,ww,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
call prec%precv(1)%sm%apply(sone,ww,szero,x,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
end do
case default
info = psb_err_from_subroutine_
@ -543,7 +550,7 @@ subroutine mld_sprecaply1_vect(prec,x,desc_data,info,trans,work)
else
call prec%precv(1)%sm%apply(sone,x,szero,ww,desc_data,trans_,&
& nswps, work_,info)
& nswps, work_,wv,info)
if (info == 0) call psb_geaxpby(sone,ww,szero,x,desc_data,info)
end if
else
@ -553,8 +560,8 @@ subroutine mld_sprecaply1_vect(prec,x,desc_data,info,trans,work)
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
endif
if (info == 0) call psb_gefree(ww,desc_data,info)
end associate
!!$ if (info == 0) call psb_gefree(ww,desc_data,info)
! If the original distribution has an overlap we should fix that.
call psb_halo(x,desc_data,info,data=psb_comm_mov_)

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_

68
mlprec/impl/mld_zmlprec_aply.f90
Unescape Escape View File

@ -255,7 +255,8 @@ subroutine mld_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv(:))
!
! At first iteration we must use the input BETA
!
@ -482,7 +483,8 @@ contains
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
if (allocated(p%precv(level)%sm2a)) then
call psb_geaxpby(zone,&
@ -494,12 +496,12 @@ contains
call p%precv(level)%sm%apply(zone,&
& vy2l,zzero,vty,&
& base_desc, trans,&
& ione,work,info,init='Z')
& ione,work,wv,info,init='Z')
call p%precv(level)%sm2a%apply(zone,&
& vty,zzero,vy2l,&
& base_desc, trans,&
& ione,work,info,init='Z')
& ione,work,wv,info,init='Z')
end do
else
@ -507,7 +509,7 @@ contains
call p%precv(level)%sm%apply(zone,&
& vx2l,zzero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -519,7 +521,8 @@ contains
! Apply the restriction
call psb_map_X2Y(zone,vx2l,&
& zzero,p%precv(level+1)%wrk%vx2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
@ -538,7 +541,8 @@ contains
!
call psb_map_Y2X(zone,p%precv(level+1)%wrk%vy2l,&
& zone,vy2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
@ -605,7 +609,8 @@ contains
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
if (level < nlev) then
!
! Apply the first smoother
@ -618,13 +623,13 @@ contains
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vx2l,zzero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
& vx2l,zzero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@ -651,7 +656,8 @@ contains
end if
call psb_map_X2Y(zone,vty,&
& zzero,p%precv(level+1)%wrk%vx2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
@ -661,7 +667,8 @@ contains
! Shortcut: just transfer x2l.
call psb_map_X2Y(zone,vx2l,&
& zzero,p%precv(level+1)%wrk%vx2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction')
@ -676,7 +683,8 @@ contains
!
call psb_map_Y2X(zone,p%precv(level+1)%wrk%vy2l,&
& zone,vy2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
@ -693,7 +701,8 @@ contains
& base_desc,info,work=work,trans=trans)
if (info == psb_success_) call psb_map_X2Y(zone,vty,&
& zzero,p%precv(level+1)%wrk%vx2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during W-cycle restriction')
@ -704,7 +713,8 @@ contains
if (info == psb_success_) call psb_map_Y2X(zone,p%precv(level+1)%wrk%vy2l,&
& zone,vy2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -737,13 +747,13 @@ contains
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
& vty,zone,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vty,zone,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@ -760,7 +770,7 @@ contains
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vx2l,zzero,vy2l,&
& base_desc, trans,&
& sweeps,work,info)
& sweeps,work,wv,info)
else
@ -836,7 +846,8 @@ contains
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
if (level == nlev) then
!
! Apply smoother
@ -845,7 +856,7 @@ contains
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vx2l,zzero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else if (level < nlev) then
@ -854,13 +865,13 @@ contains
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vx2l,zzero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_post
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
& vx2l,zzero,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@ -890,7 +901,8 @@ contains
! Apply the restriction
call psb_map_X2Y(zone,vty,&
& zzero,p%precv(level + 1)%wrk%vx2l,&
& p%precv(level + 1)%map,info,work=work)
& p%precv(level + 1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -925,7 +937,8 @@ contains
!
call psb_map_Y2X(zone,p%precv(level+1)%wrk%vy2l,&
& zone,vy2l,&
& p%precv(level+1)%map,info,work=work)
& p%precv(level+1)%map,info,work=work,&
& vtx=wv(1),vty=wv(2))
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
@ -955,13 +968,13 @@ contains
if (info == psb_success_) call p%precv(level)%sm2%apply(zone,&
& vty,zone,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
else
sweeps = p%precv(level)%parms%sweeps_pre
if (info == psb_success_) call p%precv(level)%sm%apply(zone,&
& vty,zone,vy2l,&
& base_desc, trans,&
& sweeps,work,info,init='Z')
& sweeps,work,wv,info,init='Z')
end if
if (info /= psb_success_) then
@ -1014,7 +1027,8 @@ contains
associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,&
& vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,&
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc)
& base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,&
& wv => p%precv(level)%wrk%wv)
!Assemble rhs, w, v, v1, x

49
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%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)
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.
!
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.)
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)
& 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,6 +500,11 @@ subroutine mld_zprecaply1_vect(prec,x,desc_data,info,trans,work)
call psb_errpush(info,name)
goto 9999
end if
do_alloc_wrk = .not.allocated(prec%wrk)
if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
associate(ww => prec%precv(1)%wrk%vtx, wv => prec%precv(1)%wrk%wv)
call psb_geasb(ww,desc_data,info,mold=x%v,scratch=.true.)
if (size(prec%precv) >1) then
!
@ -524,16 +531,16 @@ subroutine mld_zprecaply1_vect(prec,x,desc_data,info,trans,work)
case ('N')
do k=1, nswps
call prec%precv(1)%sm%apply(zone,x,zzero,ww,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(zone,ww,zzero,x,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,x,zzero,ww,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
call prec%precv(1)%sm%apply(zone,ww,zzero,x,desc_data,trans_,&
& ione, work_,info)
& ione, work_,wv,info)
end do
case default
info = psb_err_from_subroutine_
@ -543,7 +550,7 @@ subroutine mld_zprecaply1_vect(prec,x,desc_data,info,trans,work)
else
call prec%precv(1)%sm%apply(zone,x,zzero,ww,desc_data,trans_,&
& nswps, work_,info)
& nswps, work_,wv,info)
if (info == 0) call psb_geaxpby(zone,ww,zzero,x,desc_data,info)
end if
else
@ -553,8 +560,8 @@ subroutine mld_zprecaply1_vect(prec,x,desc_data,info,trans,work)
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
endif
if (info == 0) call psb_gefree(ww,desc_data,info)
end associate
!!$ if (info == 0) call psb_gefree(ww,desc_data,info)
! If the original distribution has an overlap we should fix that.
call psb_halo(x,desc_data,info,data=psb_comm_mov_)

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_

25
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,wv)
& 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,10 +48,10 @@ 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
type(psb_c_vect_type),intent(inout), optional :: wv(:)
integer(psb_ipk_) :: n_row,n_col, nrow_d, i
complex(psb_spk_), pointer :: aux(:)
@ -125,9 +125,16 @@ 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.)
if (size(wv) < 3) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end if
associate(tx => wv(1), ty => wv(2), ww => wv(3))
!!$ 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()
!
@ -205,7 +212,7 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
!
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
end associate
else
@ -220,9 +227,9 @@ 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) 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)

4
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,wv)
& 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,10 @@ 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
type(psb_c_vect_type),intent(inout), optional :: wv(:)
!
integer(psb_ipk_) :: err_act
character(len=20) :: name='c_base_smoother_apply'

33
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,wv)
& 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,10 @@ 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
type(psb_c_vect_type),intent(inout), optional :: wv(:)
!
integer(psb_ipk_) :: n_row,n_col
type(psb_c_vect_type) :: tx, ty
@ -122,8 +122,16 @@ 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.)
if (size(wv) < 2) then
info = psb_err_internal_error_
write(0,*) 'Size (WV) : ',size(wv)
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end if
associate(tx => wv(1), ty => wv(2))
!!$ call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.)
!!$ call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.)
!
@ -184,14 +192,15 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
goto 9999
end if
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
!!$ 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
end associate
else

25
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,wv)
& 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,10 +48,10 @@ 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
type(psb_d_vect_type),intent(inout), optional :: wv(:)
integer(psb_ipk_) :: n_row,n_col, nrow_d, i
real(psb_dpk_), pointer :: aux(:)
@ -125,9 +125,16 @@ 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.)
if (size(wv) < 3) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end if
associate(tx => wv(1), ty => wv(2), ww => wv(3))
!!$ 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()
!
@ -205,7 +212,7 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
!
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
end associate
else
@ -220,9 +227,9 @@ 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) 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)

4
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,wv)
& 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,10 @@ 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
type(psb_d_vect_type),intent(inout), optional :: wv(:)
!
integer(psb_ipk_) :: err_act
character(len=20) :: name='d_base_smoother_apply'

33
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,wv)
& 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,10 @@ 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
type(psb_d_vect_type),intent(inout), optional :: wv(:)
!
integer(psb_ipk_) :: n_row,n_col
type(psb_d_vect_type) :: tx, ty
@ -122,8 +122,16 @@ 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.)
if (size(wv) < 2) then
info = psb_err_internal_error_
write(0,*) 'Size (WV) : ',size(wv)
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end if
associate(tx => wv(1), ty => wv(2))
!!$ call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.)
!!$ call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.)
!
@ -184,14 +192,15 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
goto 9999
end if
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
!!$ 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
end associate
else

25
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,wv)
& 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,10 +48,10 @@ 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
type(psb_s_vect_type),intent(inout), optional :: wv(:)
integer(psb_ipk_) :: n_row,n_col, nrow_d, i
real(psb_spk_), pointer :: aux(:)
@ -125,9 +125,16 @@ 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.)
if (size(wv) < 3) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end if
associate(tx => wv(1), ty => wv(2), ww => wv(3))
!!$ 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()
!
@ -205,7 +212,7 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
!
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
end associate
else
@ -220,9 +227,9 @@ 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) 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)

4
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,wv)
& 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,10 @@ 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
type(psb_s_vect_type),intent(inout), optional :: wv(:)
!
integer(psb_ipk_) :: err_act
character(len=20) :: name='s_base_smoother_apply'

33
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,wv)
& 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,10 @@ 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
type(psb_s_vect_type),intent(inout), optional :: wv(:)
!
integer(psb_ipk_) :: n_row,n_col
type(psb_s_vect_type) :: tx, ty
@ -122,8 +122,16 @@ 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.)
if (size(wv) < 2) then
info = psb_err_internal_error_
write(0,*) 'Size (WV) : ',size(wv)
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end if
associate(tx => wv(1), ty => wv(2))
!!$ call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.)
!!$ call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.)
!
@ -184,14 +192,15 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
goto 9999
end if
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
!!$ 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
end associate
else

25
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,wv)
& 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,10 +48,10 @@ 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
type(psb_z_vect_type),intent(inout), optional :: wv(:)
integer(psb_ipk_) :: n_row,n_col, nrow_d, i
complex(psb_dpk_), pointer :: aux(:)
@ -125,9 +125,16 @@ 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.)
if (size(wv) < 3) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end if
associate(tx => wv(1), ty => wv(2), ww => wv(3))
!!$ 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()
!
@ -205,7 +212,7 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx)
!
call psb_geaxpby(alpha,ty,beta,y,desc_data,info)
end associate
else
@ -220,9 +227,9 @@ 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) 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)

4
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,wv)
& 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,10 @@ 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
type(psb_z_vect_type),intent(inout), optional :: wv(:)
!
integer(psb_ipk_) :: err_act
character(len=20) :: name='z_base_smoother_apply'

33
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,wv)
& 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,10 @@ 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
type(psb_z_vect_type),intent(inout), optional :: wv(:)
!
integer(psb_ipk_) :: n_row,n_col
type(psb_z_vect_type) :: tx, ty
@ -122,8 +122,16 @@ 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.)
if (size(wv) < 2) then
info = psb_err_internal_error_
write(0,*) 'Size (WV) : ',size(wv)
call psb_errpush(info,name,&
& a_err='invalid wv size in smoother_apply')
goto 9999
end if
associate(tx => wv(1), ty => wv(2))
!!$ call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.)
!!$ call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.)
!
@ -184,14 +192,15 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
goto 9999
end if
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
!!$ 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
end associate
else

4
mlprec/mld_c_as_smoother.f90
Unescape Escape View File

@ -181,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,wv)
& 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_
@ -194,10 +194,10 @@ 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
type(psb_c_vect_type),intent(inout), optional :: wv(:)
end subroutine mld_c_as_smoother_apply_vect
end interface

4
mlprec/mld_c_base_smoother_mod.f90
Unescape Escape View File

@ -158,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,wv)
& 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_
@ -170,10 +170,10 @@ 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
type(psb_c_vect_type),intent(inout), optional :: wv(:)
end subroutine mld_c_base_smoother_apply_vect
end interface

4
mlprec/mld_c_jac_smoother.f90
Unescape Escape View File

@ -85,7 +85,7 @@ module mld_c_jac_smoother
interface
subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info,init,initu,wv)
& 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_
@ -98,10 +98,10 @@ 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
type(psb_c_vect_type),intent(inout), optional :: wv(:)
end subroutine mld_c_jac_smoother_apply_vect
end interface

17
mlprec/mld_c_onelev_mod.f90
Unescape Escape View File

@ -583,10 +583,9 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_c_base_vect_type), intent(in), optional :: vmold
!
integer(psb_ipk_) :: nwv
integer(psb_ipk_) :: nwv, i
info = psb_success_
nwv = lv%get_wrksz()
write(0,*) 'Debug allocate_wrk: ',nwv
call psb_geasb(lv%wrk%vx2l,&
& lv%base_desc,info,&
& scratch=.true.,mold=vmold)
@ -599,7 +598,12 @@ contains
call psb_geasb(lv%wrk%vty,&
& lv%base_desc,info,&
& scratch=.true.,mold=vmold)
allocate(lv%wrk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(lv%wrk%wv(i),&
& lv%base_desc,info,&
& scratch=.true.,mold=vmold)
end do
end subroutine c_base_onelev_allocate_wrk
@ -609,12 +613,17 @@ contains
class(mld_c_onelev_type), target, intent(inout) :: lv
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: nwv
integer(psb_ipk_) :: nwv,i
info = psb_success_
call lv%wrk%vx2l%free(info)
call lv%wrk%vy2l%free(info)
call lv%wrk%vtx%free(info)
call lv%wrk%vty%free(info)
nwv = size(lv%wrk%wv)
do i=1,nwv
call lv%wrk%wv(i)%free(info)
end do
end subroutine c_base_onelev_free_wrk
end module mld_c_onelev_mod

4
mlprec/mld_d_as_smoother.f90
Unescape Escape View File

@ -181,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,wv)
& 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_
@ -194,10 +194,10 @@ 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
type(psb_d_vect_type),intent(inout), optional :: wv(:)
end subroutine mld_d_as_smoother_apply_vect
end interface

4
mlprec/mld_d_base_smoother_mod.f90
Unescape Escape View File

@ -158,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,wv)
& 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_
@ -170,10 +170,10 @@ 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
type(psb_d_vect_type),intent(inout), optional :: wv(:)
end subroutine mld_d_base_smoother_apply_vect
end interface

4
mlprec/mld_d_jac_smoother.f90
Unescape Escape View File

@ -85,7 +85,7 @@ module mld_d_jac_smoother
interface
subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info,init,initu,wv)
& 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_
@ -98,10 +98,10 @@ 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
type(psb_d_vect_type),intent(inout), optional :: wv(:)
end subroutine mld_d_jac_smoother_apply_vect
end interface

17
mlprec/mld_d_onelev_mod.f90
Unescape Escape View File

@ -583,10 +583,9 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: vmold
!
integer(psb_ipk_) :: nwv
integer(psb_ipk_) :: nwv, i
info = psb_success_
nwv = lv%get_wrksz()
write(0,*) 'Debug allocate_wrk: ',nwv
call psb_geasb(lv%wrk%vx2l,&
& lv%base_desc,info,&
& scratch=.true.,mold=vmold)
@ -599,7 +598,12 @@ contains
call psb_geasb(lv%wrk%vty,&
& lv%base_desc,info,&
& scratch=.true.,mold=vmold)
allocate(lv%wrk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(lv%wrk%wv(i),&
& lv%base_desc,info,&
& scratch=.true.,mold=vmold)
end do
end subroutine d_base_onelev_allocate_wrk
@ -609,12 +613,17 @@ contains
class(mld_d_onelev_type), target, intent(inout) :: lv
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: nwv
integer(psb_ipk_) :: nwv,i
info = psb_success_
call lv%wrk%vx2l%free(info)
call lv%wrk%vy2l%free(info)
call lv%wrk%vtx%free(info)
call lv%wrk%vty%free(info)
nwv = size(lv%wrk%wv)
do i=1,nwv
call lv%wrk%wv(i)%free(info)
end do
end subroutine d_base_onelev_free_wrk
end module mld_d_onelev_mod

4
mlprec/mld_s_as_smoother.f90
Unescape Escape View File

@ -181,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,wv)
& 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_
@ -194,10 +194,10 @@ 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
type(psb_s_vect_type),intent(inout), optional :: wv(:)
end subroutine mld_s_as_smoother_apply_vect
end interface

4
mlprec/mld_s_base_smoother_mod.f90
Unescape Escape View File

@ -158,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,wv)
& 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_
@ -170,10 +170,10 @@ 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
type(psb_s_vect_type),intent(inout), optional :: wv(:)
end subroutine mld_s_base_smoother_apply_vect
end interface

4
mlprec/mld_s_jac_smoother.f90
Unescape Escape View File

@ -85,7 +85,7 @@ module mld_s_jac_smoother
interface
subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info,init,initu,wv)
& 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_
@ -98,10 +98,10 @@ 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
type(psb_s_vect_type),intent(inout), optional :: wv(:)
end subroutine mld_s_jac_smoother_apply_vect
end interface

17
mlprec/mld_s_onelev_mod.f90
Unescape Escape View File

@ -583,10 +583,9 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_s_base_vect_type), intent(in), optional :: vmold
!
integer(psb_ipk_) :: nwv
integer(psb_ipk_) :: nwv, i
info = psb_success_
nwv = lv%get_wrksz()
write(0,*) 'Debug allocate_wrk: ',nwv
call psb_geasb(lv%wrk%vx2l,&
& lv%base_desc,info,&
& scratch=.true.,mold=vmold)
@ -599,7 +598,12 @@ contains
call psb_geasb(lv%wrk%vty,&
& lv%base_desc,info,&
& scratch=.true.,mold=vmold)
allocate(lv%wrk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(lv%wrk%wv(i),&
& lv%base_desc,info,&
& scratch=.true.,mold=vmold)
end do
end subroutine s_base_onelev_allocate_wrk
@ -609,12 +613,17 @@ contains
class(mld_s_onelev_type), target, intent(inout) :: lv
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: nwv
integer(psb_ipk_) :: nwv,i
info = psb_success_
call lv%wrk%vx2l%free(info)
call lv%wrk%vy2l%free(info)
call lv%wrk%vtx%free(info)
call lv%wrk%vty%free(info)
nwv = size(lv%wrk%wv)
do i=1,nwv
call lv%wrk%wv(i)%free(info)
end do
end subroutine s_base_onelev_free_wrk
end module mld_s_onelev_mod

4
mlprec/mld_z_as_smoother.f90
Unescape Escape View File

@ -181,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,wv)
& 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_
@ -194,10 +194,10 @@ 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
type(psb_z_vect_type),intent(inout), optional :: wv(:)
end subroutine mld_z_as_smoother_apply_vect
end interface

4
mlprec/mld_z_base_smoother_mod.f90
Unescape Escape View File

@ -158,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,wv)
& 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_
@ -170,10 +170,10 @@ 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
type(psb_z_vect_type),intent(inout), optional :: wv(:)
end subroutine mld_z_base_smoother_apply_vect
end interface

4
mlprec/mld_z_jac_smoother.f90
Unescape Escape View File

@ -85,7 +85,7 @@ module mld_z_jac_smoother
interface
subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& sweeps,work,info,init,initu,wv)
& sweeps,work,wv,info,init,initu)
import :: psb_desc_type, mld_z_jac_smoother_type, psb_z_vect_type, psb_dpk_, &
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,&
& psb_ipk_
@ -98,10 +98,10 @@ module mld_z_jac_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
type(psb_z_vect_type),intent(inout), optional :: wv(:)
end subroutine mld_z_jac_smoother_apply_vect
end interface

17
mlprec/mld_z_onelev_mod.f90
Unescape Escape View File

@ -583,10 +583,9 @@ contains
integer(psb_ipk_), intent(out) :: info
class(psb_z_base_vect_type), intent(in), optional :: vmold
!
integer(psb_ipk_) :: nwv
integer(psb_ipk_) :: nwv, i
info = psb_success_
nwv = lv%get_wrksz()
write(0,*) 'Debug allocate_wrk: ',nwv
call psb_geasb(lv%wrk%vx2l,&
& lv%base_desc,info,&
& scratch=.true.,mold=vmold)
@ -599,7 +598,12 @@ contains
call psb_geasb(lv%wrk%vty,&
& lv%base_desc,info,&
& scratch=.true.,mold=vmold)
allocate(lv%wrk%wv(nwv),stat=info)
do i=1,nwv
call psb_geasb(lv%wrk%wv(i),&
& lv%base_desc,info,&
& scratch=.true.,mold=vmold)
end do
end subroutine z_base_onelev_allocate_wrk
@ -609,12 +613,17 @@ contains
class(mld_z_onelev_type), target, intent(inout) :: lv
integer(psb_ipk_), intent(out) :: info
!
integer(psb_ipk_) :: nwv
integer(psb_ipk_) :: nwv,i
info = psb_success_
call lv%wrk%vx2l%free(info)
call lv%wrk%vy2l%free(info)
call lv%wrk%vtx%free(info)
call lv%wrk%vty%free(info)
nwv = size(lv%wrk%wv)
do i=1,nwv
call lv%wrk%wv(i)%free(info)
end do
end subroutine z_base_onelev_free_wrk
end module mld_z_onelev_mod

Write Preview
Loading…
Cancel
Save