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

Check error conditions in single level apply. Make sure AS vectors are good.

Browse Source
stopcriterion
Salvatore Filippone 7 years ago
parent cbe0a5754f
commit 6178a2ec13
8 changed files with 196 additions and 60 deletions
Show Stats Download Patch File Download Diff File

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

@ -391,17 +391,17 @@ subroutine mld_cprecaply2_vect(prec,x,y,desc_data,info,trans,work)
select case(trans_) select case(trans_)
case ('N') case ('N')
do k=1, nswps do k=1, nswps
call prec%precv(1)%sm%apply(cone,w1,czero,w2,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(cone,w1,czero,w2,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(cone,w2,czero,w1,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm2a%apply(cone,w2,czero,w1,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
end do end do
case('T','C') case('T','C')
do k=1, nswps do k=1, nswps
call prec%precv(1)%sm2a%apply(cone,w1,czero,w2,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm2a%apply(cone,w1,czero,w2,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
call prec%precv(1)%sm%apply(cone,w2,czero,w1,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(cone,w2,czero,w1,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
end do end do
case default case default
@ -409,15 +409,22 @@ subroutine mld_cprecaply2_vect(prec,x,y,desc_data,info,trans,work)
call psb_errpush(info,name,a_err='Invalid trans') call psb_errpush(info,name,a_err='Invalid trans')
goto 9999 goto 9999
end select end select
call psb_geaxpby(cone,w1,czero,y,desc_data,info) if (info == 0) call psb_geaxpby(cone,w1,czero,y,desc_data,info)
else else
call prec%precv(1)%sm%apply(cone,x,czero,y,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(cone,x,czero,y,desc_data,trans_,&
& nswps,work_,wv,info) & nswps,work_,wv,info)
end if end if
end associate end associate
if (psb_get_errstatus() /=0) info = psb_err_internal_error_
if (info /= 0) then
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Smoother application',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
end if
else else
info = psb_err_from_subroutine_ai_ info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',& call psb_errpush(info,name,a_err='Invalid size of precv',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/)) & i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
@ -530,16 +537,16 @@ subroutine mld_cprecaply1_vect(prec,x,desc_data,info,trans,work)
select case(trans_) select case(trans_)
case ('N') case ('N')
do k=1, nswps do k=1, nswps
call prec%precv(1)%sm%apply(cone,x,czero,ww,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(cone,x,czero,ww,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(cone,ww,czero,x,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm2a%apply(cone,ww,czero,x,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
end do end do
case('T','C') case('T','C')
do k=1, nswps do k=1, nswps
call prec%precv(1)%sm2a%apply(cone,x,czero,ww,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm2a%apply(cone,x,czero,ww,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
call prec%precv(1)%sm%apply(cone,ww,czero,x,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(cone,ww,czero,x,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
end do end do
case default case default
@ -549,10 +556,19 @@ subroutine mld_cprecaply1_vect(prec,x,desc_data,info,trans,work)
end select end select
else else
call prec%precv(1)%sm%apply(cone,x,czero,ww,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(cone,x,czero,ww,desc_data,trans_,&
& nswps, work_,wv,info) & nswps, work_,wv,info)
if (info == 0) call psb_geaxpby(cone,ww,czero,x,desc_data,info) if (info == 0) call psb_geaxpby(cone,ww,czero,x,desc_data,info)
end if end if
if (psb_get_errstatus() /=0) info = psb_err_internal_error_
if (info /=0) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Smoother application',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
end if
else else
info = psb_err_from_subroutine_ai_ info = psb_err_from_subroutine_ai_

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

@ -391,17 +391,17 @@ subroutine mld_dprecaply2_vect(prec,x,y,desc_data,info,trans,work)
select case(trans_) select case(trans_)
case ('N') case ('N')
do k=1, nswps do k=1, nswps
call prec%precv(1)%sm%apply(done,w1,dzero,w2,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(done,w1,dzero,w2,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(done,w2,dzero,w1,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm2a%apply(done,w2,dzero,w1,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
end do end do
case('T','C') case('T','C')
do k=1, nswps do k=1, nswps
call prec%precv(1)%sm2a%apply(done,w1,dzero,w2,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm2a%apply(done,w1,dzero,w2,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
call prec%precv(1)%sm%apply(done,w2,dzero,w1,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(done,w2,dzero,w1,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
end do end do
case default case default
@ -409,15 +409,22 @@ subroutine mld_dprecaply2_vect(prec,x,y,desc_data,info,trans,work)
call psb_errpush(info,name,a_err='Invalid trans') call psb_errpush(info,name,a_err='Invalid trans')
goto 9999 goto 9999
end select end select
call psb_geaxpby(done,w1,dzero,y,desc_data,info) if (info == 0) call psb_geaxpby(done,w1,dzero,y,desc_data,info)
else else
call prec%precv(1)%sm%apply(done,x,dzero,y,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(done,x,dzero,y,desc_data,trans_,&
& nswps,work_,wv,info) & nswps,work_,wv,info)
end if end if
end associate end associate
if (psb_get_errstatus() /=0) info = psb_err_internal_error_
if (info /= 0) then
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Smoother application',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
end if
else else
info = psb_err_from_subroutine_ai_ info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',& call psb_errpush(info,name,a_err='Invalid size of precv',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/)) & i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
@ -530,16 +537,16 @@ subroutine mld_dprecaply1_vect(prec,x,desc_data,info,trans,work)
select case(trans_) select case(trans_)
case ('N') case ('N')
do k=1, nswps do k=1, nswps
call prec%precv(1)%sm%apply(done,x,dzero,ww,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(done,x,dzero,ww,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(done,ww,dzero,x,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm2a%apply(done,ww,dzero,x,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
end do end do
case('T','C') case('T','C')
do k=1, nswps do k=1, nswps
call prec%precv(1)%sm2a%apply(done,x,dzero,ww,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm2a%apply(done,x,dzero,ww,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
call prec%precv(1)%sm%apply(done,ww,dzero,x,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(done,ww,dzero,x,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
end do end do
case default case default
@ -549,10 +556,19 @@ subroutine mld_dprecaply1_vect(prec,x,desc_data,info,trans,work)
end select end select
else else
call prec%precv(1)%sm%apply(done,x,dzero,ww,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(done,x,dzero,ww,desc_data,trans_,&
& nswps, work_,wv,info) & nswps, work_,wv,info)
if (info == 0) call psb_geaxpby(done,ww,dzero,x,desc_data,info) if (info == 0) call psb_geaxpby(done,ww,dzero,x,desc_data,info)
end if end if
if (psb_get_errstatus() /=0) info = psb_err_internal_error_
if (info /=0) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Smoother application',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
end if
else else
info = psb_err_from_subroutine_ai_ info = psb_err_from_subroutine_ai_

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

@ -391,17 +391,17 @@ subroutine mld_sprecaply2_vect(prec,x,y,desc_data,info,trans,work)
select case(trans_) select case(trans_)
case ('N') case ('N')
do k=1, nswps do k=1, nswps
call prec%precv(1)%sm%apply(sone,w1,szero,w2,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(sone,w1,szero,w2,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(sone,w2,szero,w1,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm2a%apply(sone,w2,szero,w1,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
end do end do
case('T','C') case('T','C')
do k=1, nswps do k=1, nswps
call prec%precv(1)%sm2a%apply(sone,w1,szero,w2,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm2a%apply(sone,w1,szero,w2,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
call prec%precv(1)%sm%apply(sone,w2,szero,w1,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(sone,w2,szero,w1,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
end do end do
case default case default
@ -409,15 +409,22 @@ subroutine mld_sprecaply2_vect(prec,x,y,desc_data,info,trans,work)
call psb_errpush(info,name,a_err='Invalid trans') call psb_errpush(info,name,a_err='Invalid trans')
goto 9999 goto 9999
end select end select
call psb_geaxpby(sone,w1,szero,y,desc_data,info) if (info == 0) call psb_geaxpby(sone,w1,szero,y,desc_data,info)
else else
call prec%precv(1)%sm%apply(sone,x,szero,y,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(sone,x,szero,y,desc_data,trans_,&
& nswps,work_,wv,info) & nswps,work_,wv,info)
end if end if
end associate end associate
if (psb_get_errstatus() /=0) info = psb_err_internal_error_
if (info /= 0) then
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Smoother application',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
end if
else else
info = psb_err_from_subroutine_ai_ info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',& call psb_errpush(info,name,a_err='Invalid size of precv',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/)) & i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
@ -530,16 +537,16 @@ subroutine mld_sprecaply1_vect(prec,x,desc_data,info,trans,work)
select case(trans_) select case(trans_)
case ('N') case ('N')
do k=1, nswps do k=1, nswps
call prec%precv(1)%sm%apply(sone,x,szero,ww,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(sone,x,szero,ww,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(sone,ww,szero,x,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm2a%apply(sone,ww,szero,x,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
end do end do
case('T','C') case('T','C')
do k=1, nswps do k=1, nswps
call prec%precv(1)%sm2a%apply(sone,x,szero,ww,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm2a%apply(sone,x,szero,ww,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
call prec%precv(1)%sm%apply(sone,ww,szero,x,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(sone,ww,szero,x,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
end do end do
case default case default
@ -549,10 +556,19 @@ subroutine mld_sprecaply1_vect(prec,x,desc_data,info,trans,work)
end select end select
else else
call prec%precv(1)%sm%apply(sone,x,szero,ww,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(sone,x,szero,ww,desc_data,trans_,&
& nswps, work_,wv,info) & nswps, work_,wv,info)
if (info == 0) call psb_geaxpby(sone,ww,szero,x,desc_data,info) if (info == 0) call psb_geaxpby(sone,ww,szero,x,desc_data,info)
end if end if
if (psb_get_errstatus() /=0) info = psb_err_internal_error_
if (info /=0) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Smoother application',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
end if
else else
info = psb_err_from_subroutine_ai_ info = psb_err_from_subroutine_ai_

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

@ -391,17 +391,17 @@ subroutine mld_zprecaply2_vect(prec,x,y,desc_data,info,trans,work)
select case(trans_) select case(trans_)
case ('N') case ('N')
do k=1, nswps do k=1, nswps
call prec%precv(1)%sm%apply(zone,w1,zzero,w2,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(zone,w1,zzero,w2,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(zone,w2,zzero,w1,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm2a%apply(zone,w2,zzero,w1,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
end do end do
case('T','C') case('T','C')
do k=1, nswps do k=1, nswps
call prec%precv(1)%sm2a%apply(zone,w1,zzero,w2,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm2a%apply(zone,w1,zzero,w2,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
call prec%precv(1)%sm%apply(zone,w2,zzero,w1,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(zone,w2,zzero,w1,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
end do end do
case default case default
@ -409,15 +409,22 @@ subroutine mld_zprecaply2_vect(prec,x,y,desc_data,info,trans,work)
call psb_errpush(info,name,a_err='Invalid trans') call psb_errpush(info,name,a_err='Invalid trans')
goto 9999 goto 9999
end select end select
call psb_geaxpby(zone,w1,zzero,y,desc_data,info) if (info == 0) call psb_geaxpby(zone,w1,zzero,y,desc_data,info)
else else
call prec%precv(1)%sm%apply(zone,x,zzero,y,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(zone,x,zzero,y,desc_data,trans_,&
& nswps,work_,wv,info) & nswps,work_,wv,info)
end if end if
end associate end associate
if (psb_get_errstatus() /=0) info = psb_err_internal_error_
if (info /= 0) then
info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Smoother application',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
end if
else else
info = psb_err_from_subroutine_ai_ info = psb_err_from_subroutine_ai_
call psb_errpush(info,name,a_err='Invalid size of precv',& call psb_errpush(info,name,a_err='Invalid size of precv',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/)) & i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
@ -530,16 +537,16 @@ subroutine mld_zprecaply1_vect(prec,x,desc_data,info,trans,work)
select case(trans_) select case(trans_)
case ('N') case ('N')
do k=1, nswps do k=1, nswps
call prec%precv(1)%sm%apply(zone,x,zzero,ww,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(zone,x,zzero,ww,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
call prec%precv(1)%sm2a%apply(zone,ww,zzero,x,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm2a%apply(zone,ww,zzero,x,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
end do end do
case('T','C') case('T','C')
do k=1, nswps do k=1, nswps
call prec%precv(1)%sm2a%apply(zone,x,zzero,ww,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm2a%apply(zone,x,zzero,ww,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
call prec%precv(1)%sm%apply(zone,ww,zzero,x,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(zone,ww,zzero,x,desc_data,trans_,&
& ione, work_,wv,info) & ione, work_,wv,info)
end do end do
case default case default
@ -549,10 +556,19 @@ subroutine mld_zprecaply1_vect(prec,x,desc_data,info,trans,work)
end select end select
else else
call prec%precv(1)%sm%apply(zone,x,zzero,ww,desc_data,trans_,& if (info == 0) call prec%precv(1)%sm%apply(zone,x,zzero,ww,desc_data,trans_,&
& nswps, work_,wv,info) & nswps, work_,wv,info)
if (info == 0) call psb_geaxpby(zone,ww,zzero,x,desc_data,info) if (info == 0) call psb_geaxpby(zone,ww,zzero,x,desc_data,info)
end if end if
if (psb_get_errstatus() /=0) info = psb_err_internal_error_
if (info /=0) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Smoother application',&
& i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/))
goto 9999
end if
else else
info = psb_err_from_subroutine_ai_ info = psb_err_from_subroutine_ai_

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

@ -58,6 +58,7 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
type(psb_c_vect_type) :: tx, ty, ww type(psb_c_vect_type) :: tx, ty, ww
integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5) integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5)
character :: trans_, init_ character :: trans_, init_
logical :: do_realloc_wv
character(len=20) :: name='c_as_smoother_apply_v', ch_err character(len=20) :: name='c_as_smoother_apply_v', ch_err
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -130,8 +131,25 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& a_err='invalid wv size in smoother_apply') & a_err='invalid wv size in smoother_apply')
goto 9999 goto 9999
end if end if
associate(tx => wv(1), ty => wv(2), ww => wv(3))
!
! This is tricky. This smoother has a descriptor sm%desc_data
! for an index space potentially different from
! that of desc_data. Hence the size of the work vectors
! could be wrong. We need to check and reallocate as needed.
!
do_realloc_wv = (wv(1)%get_nrows() < sm%desc_data%get_local_cols()).or.&
& (wv(2)%get_nrows() < sm%desc_data%get_local_cols()).or.&
& (wv(3)%get_nrows() < sm%desc_data%get_local_cols())
if (do_realloc_wv) then
call psb_geasb(wv(1),sm%desc_data,info,scratch=.true.,mold=wv(2)%v)
call psb_geasb(wv(2),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
call psb_geasb(wv(3),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
end if
associate(tx => wv(1), ty => wv(2), ww => wv(3))
! Need to zero tx because of the apply_restr call. ! Need to zero tx because of the apply_restr call.
call tx%zero() call tx%zero()
! !

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

@ -58,6 +58,7 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
type(psb_d_vect_type) :: tx, ty, ww type(psb_d_vect_type) :: tx, ty, ww
integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5) integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5)
character :: trans_, init_ character :: trans_, init_
logical :: do_realloc_wv
character(len=20) :: name='d_as_smoother_apply_v', ch_err character(len=20) :: name='d_as_smoother_apply_v', ch_err
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -130,8 +131,25 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& a_err='invalid wv size in smoother_apply') & a_err='invalid wv size in smoother_apply')
goto 9999 goto 9999
end if end if
associate(tx => wv(1), ty => wv(2), ww => wv(3))
!
! This is tricky. This smoother has a descriptor sm%desc_data
! for an index space potentially different from
! that of desc_data. Hence the size of the work vectors
! could be wrong. We need to check and reallocate as needed.
!
do_realloc_wv = (wv(1)%get_nrows() < sm%desc_data%get_local_cols()).or.&
& (wv(2)%get_nrows() < sm%desc_data%get_local_cols()).or.&
& (wv(3)%get_nrows() < sm%desc_data%get_local_cols())
if (do_realloc_wv) then
call psb_geasb(wv(1),sm%desc_data,info,scratch=.true.,mold=wv(2)%v)
call psb_geasb(wv(2),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
call psb_geasb(wv(3),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
end if
associate(tx => wv(1), ty => wv(2), ww => wv(3))
! Need to zero tx because of the apply_restr call. ! Need to zero tx because of the apply_restr call.
call tx%zero() call tx%zero()
! !

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

@ -58,6 +58,7 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
type(psb_s_vect_type) :: tx, ty, ww type(psb_s_vect_type) :: tx, ty, ww
integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5) integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5)
character :: trans_, init_ character :: trans_, init_
logical :: do_realloc_wv
character(len=20) :: name='s_as_smoother_apply_v', ch_err character(len=20) :: name='s_as_smoother_apply_v', ch_err
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -130,8 +131,25 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& a_err='invalid wv size in smoother_apply') & a_err='invalid wv size in smoother_apply')
goto 9999 goto 9999
end if end if
associate(tx => wv(1), ty => wv(2), ww => wv(3))
!
! This is tricky. This smoother has a descriptor sm%desc_data
! for an index space potentially different from
! that of desc_data. Hence the size of the work vectors
! could be wrong. We need to check and reallocate as needed.
!
do_realloc_wv = (wv(1)%get_nrows() < sm%desc_data%get_local_cols()).or.&
& (wv(2)%get_nrows() < sm%desc_data%get_local_cols()).or.&
& (wv(3)%get_nrows() < sm%desc_data%get_local_cols())
if (do_realloc_wv) then
call psb_geasb(wv(1),sm%desc_data,info,scratch=.true.,mold=wv(2)%v)
call psb_geasb(wv(2),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
call psb_geasb(wv(3),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
end if
associate(tx => wv(1), ty => wv(2), ww => wv(3))
! Need to zero tx because of the apply_restr call. ! Need to zero tx because of the apply_restr call.
call tx%zero() call tx%zero()
! !

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

@ -58,6 +58,7 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
type(psb_z_vect_type) :: tx, ty, ww type(psb_z_vect_type) :: tx, ty, ww
integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5) integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5)
character :: trans_, init_ character :: trans_, init_
logical :: do_realloc_wv
character(len=20) :: name='z_as_smoother_apply_v', ch_err character(len=20) :: name='z_as_smoother_apply_v', ch_err
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -130,8 +131,25 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
& a_err='invalid wv size in smoother_apply') & a_err='invalid wv size in smoother_apply')
goto 9999 goto 9999
end if end if
associate(tx => wv(1), ty => wv(2), ww => wv(3))
!
! This is tricky. This smoother has a descriptor sm%desc_data
! for an index space potentially different from
! that of desc_data. Hence the size of the work vectors
! could be wrong. We need to check and reallocate as needed.
!
do_realloc_wv = (wv(1)%get_nrows() < sm%desc_data%get_local_cols()).or.&
& (wv(2)%get_nrows() < sm%desc_data%get_local_cols()).or.&
& (wv(3)%get_nrows() < sm%desc_data%get_local_cols())
if (do_realloc_wv) then
call psb_geasb(wv(1),sm%desc_data,info,scratch=.true.,mold=wv(2)%v)
call psb_geasb(wv(2),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
call psb_geasb(wv(3),sm%desc_data,info,scratch=.true.,mold=wv(1)%v)
end if
associate(tx => wv(1), ty => wv(2), ww => wv(3))
! Need to zero tx because of the apply_restr call. ! Need to zero tx because of the apply_restr call.
call tx%zero() call tx%zero()
! !

Write Preview
Loading…
Cancel
Save