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

mld2p4-299

Browse Source 
mlprec/impl/mld_cmlprec_aply.f90
 mlprec/impl/mld_dmlprec_aply.f90
 mlprec/impl/mld_smlprec_aply.f90
 mlprec/impl/mld_zmlprec_aply.f90


More detailed error handling inside MLPRECAPLY.
stopcriterion
Salvatore Filippone 11 years ago
parent b784aae5cc
commit 4ce70dde60
4 changed files with 876 additions and 144 deletions
Show Stats Download Patch File Download Diff File

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

@ -488,7 +488,11 @@ contains
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
@ -565,13 +569,22 @@ contains
call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,&
& cone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,& & cone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps_post sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(cone,& call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,cone,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,cone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
@ -579,6 +592,11 @@ contains
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
end if end if
@ -615,7 +633,11 @@ contains
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
@ -624,7 +646,12 @@ contains
call psb_spmm(-cone,p%precv(level)%base_a,& call psb_spmm(-cone,p%precv(level)%base_a,&
& mlprec_wrk(level)%y2l,cone,mlprec_wrk(level)%x2l,& & mlprec_wrk(level)%y2l,cone,mlprec_wrk(level)%x2l,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) goto 9999
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -687,7 +714,11 @@ contains
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
@ -764,19 +795,35 @@ contains
call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,&
& cone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,& & cone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps_pre sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(cone,& call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,cone,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,cone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(cone,& call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
end if end if
case default case default
@ -827,6 +874,11 @@ contains
& mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
! and call recursively ! and call recursively
@ -836,6 +888,11 @@ contains
if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,&
& mlprec_wrk(level)%y2l,cone,mlprec_wrk(level)%ty,& & mlprec_wrk(level)%y2l,cone,mlprec_wrk(level)%ty,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -864,6 +921,11 @@ contains
call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,&
& cone,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,& & cone,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
! !
! Apply the base preconditioner ! Apply the base preconditioner
! !
@ -878,7 +940,7 @@ contains
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error: residual/baseprec_aply') & a_err='Error during smoother_apply')
goto 9999 goto 9999
end if end if
@ -1109,19 +1171,32 @@ contains
& mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
if (info /= psb_success_) goto 9999
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
! !
! Apply the prolongator ! Apply the prolongator
! !
call psb_map_Y2X(cone,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(cone,mlprec_wrk(level+1)%vy2l,&
& cone,mlprec_wrk(level)%vy2l,& & cone,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
end if end if
@ -1156,27 +1231,47 @@ contains
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
! !
! Apply the prolongator ! Apply the prolongator
! !
call psb_map_Y2X(cone,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(cone,mlprec_wrk(level+1)%vy2l,&
& czero,mlprec_wrk(level)%vy2l,& & czero,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
! !
! Compute the residual ! Compute the residual
! !
call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
& cone,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info,& & cone,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps_post sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(cone,& call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%vx2l,cone,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,cone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
@ -1184,6 +1279,11 @@ contains
& mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
end if end if
@ -1219,8 +1319,12 @@ contains
& mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
if (info /= psb_success_) goto 9999
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
@ -1229,14 +1333,28 @@ contains
call psb_spmm(-cone,p%precv(level)%base_a,& call psb_spmm(-cone,p%precv(level)%base_a,&
& mlprec_wrk(level)%vy2l,cone,mlprec_wrk(level)%vx2l,& & mlprec_wrk(level)%vy2l,cone,mlprec_wrk(level)%vx2l,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
call psb_map_Y2X(cone,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(cone,mlprec_wrk(level+1)%vy2l,&
& cone,mlprec_wrk(level)%vy2l,& & cone,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
end if end if
@ -1279,8 +1397,12 @@ contains
& mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
if (info /= psb_success_) goto 9999
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
@ -1289,14 +1411,29 @@ contains
call psb_spmm(-cone,p%precv(level)%base_a,& call psb_spmm(-cone,p%precv(level)%base_a,&
& mlprec_wrk(level)%vy2l,cone,mlprec_wrk(level)%vx2l,& & mlprec_wrk(level)%vy2l,cone,mlprec_wrk(level)%vx2l,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
call psb_map_Y2X(cone,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(cone,mlprec_wrk(level+1)%vy2l,&
& cone,mlprec_wrk(level)%vy2l,& & cone,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
end if end if
@ -1322,33 +1459,58 @@ contains
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
! !
! Apply the prolongator ! Apply the prolongator
! !
call psb_map_Y2X(cone,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(cone,mlprec_wrk(level+1)%vy2l,&
& czero,mlprec_wrk(level)%vy2l,& & czero,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
! !
! Compute the residual ! Compute the residual
! !
call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
& cone,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info,& & cone,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps_pre sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(cone,& call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%vx2l,cone,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,cone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(cone,& call p%precv(level)%sm%apply(cone,&
& mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
end if end if
case default case default
@ -1391,6 +1553,12 @@ contains
& mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
! and call recursively ! and call recursively
@ -1404,8 +1572,18 @@ contains
if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,&
& mlprec_wrk(level)%vy2l,cone,mlprec_wrk(level)%vty,& & mlprec_wrk(level)%vy2l,cone,mlprec_wrk(level)%vty,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
! !
@ -1417,7 +1595,7 @@ contains
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction') & a_err='Error during prolongation')
goto 9999 goto 9999
end if end if
@ -1427,6 +1605,11 @@ contains
call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
& cone,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,& & cone,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
! !
! Apply the base preconditioner ! Apply the base preconditioner
! !
@ -1441,7 +1624,7 @@ contains
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error: residual/baseprec_aply') & a_err='Error during smoother_apply')
goto 9999 goto 9999
end if end if

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

@ -488,7 +488,11 @@ contains
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
@ -565,13 +569,22 @@ contains
call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%y2l,&
& done,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,& & done,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps_post sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(done,& call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%x2l,done,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,done,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
@ -579,6 +592,11 @@ contains
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
end if end if
@ -615,7 +633,11 @@ contains
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
@ -624,7 +646,12 @@ contains
call psb_spmm(-done,p%precv(level)%base_a,& call psb_spmm(-done,p%precv(level)%base_a,&
& mlprec_wrk(level)%y2l,done,mlprec_wrk(level)%x2l,& & mlprec_wrk(level)%y2l,done,mlprec_wrk(level)%x2l,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) goto 9999
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -687,7 +714,11 @@ contains
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
@ -764,19 +795,35 @@ contains
call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%y2l,&
& done,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,& & done,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps_pre sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(done,& call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%x2l,done,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,done,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(done,& call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
end if end if
case default case default
@ -827,6 +874,11 @@ contains
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
! and call recursively ! and call recursively
@ -836,6 +888,11 @@ contains
if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,&
& mlprec_wrk(level)%y2l,done,mlprec_wrk(level)%ty,& & mlprec_wrk(level)%y2l,done,mlprec_wrk(level)%ty,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -864,6 +921,11 @@ contains
call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%y2l,&
& done,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,& & done,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
! !
! Apply the base preconditioner ! Apply the base preconditioner
! !
@ -878,7 +940,7 @@ contains
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error: residual/baseprec_aply') & a_err='Error during smoother_apply')
goto 9999 goto 9999
end if end if
@ -1109,19 +1171,32 @@ contains
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
if (info /= psb_success_) goto 9999
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
! !
! Apply the prolongator ! Apply the prolongator
! !
call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,&
& done,mlprec_wrk(level)%vy2l,& & done,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
end if end if
@ -1156,27 +1231,47 @@ contains
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
! !
! Apply the prolongator ! Apply the prolongator
! !
call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,&
& dzero,mlprec_wrk(level)%vy2l,& & dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
! !
! Compute the residual ! Compute the residual
! !
call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
& done,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info,& & done,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps_post sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(done,& call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%vx2l,done,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,done,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
@ -1184,6 +1279,11 @@ contains
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
end if end if
@ -1219,8 +1319,12 @@ contains
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
if (info /= psb_success_) goto 9999
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
@ -1229,14 +1333,28 @@ contains
call psb_spmm(-done,p%precv(level)%base_a,& call psb_spmm(-done,p%precv(level)%base_a,&
& mlprec_wrk(level)%vy2l,done,mlprec_wrk(level)%vx2l,& & mlprec_wrk(level)%vy2l,done,mlprec_wrk(level)%vx2l,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,&
& done,mlprec_wrk(level)%vy2l,& & done,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
end if end if
@ -1279,8 +1397,12 @@ contains
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
if (info /= psb_success_) goto 9999
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
@ -1289,14 +1411,29 @@ contains
call psb_spmm(-done,p%precv(level)%base_a,& call psb_spmm(-done,p%precv(level)%base_a,&
& mlprec_wrk(level)%vy2l,done,mlprec_wrk(level)%vx2l,& & mlprec_wrk(level)%vy2l,done,mlprec_wrk(level)%vx2l,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,&
& done,mlprec_wrk(level)%vy2l,& & done,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
end if end if
@ -1322,33 +1459,58 @@ contains
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
! !
! Apply the prolongator ! Apply the prolongator
! !
call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,&
& dzero,mlprec_wrk(level)%vy2l,& & dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
! !
! Compute the residual ! Compute the residual
! !
call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
& done,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info,& & done,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps_pre sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(done,& call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%vx2l,done,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,done,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(done,& call p%precv(level)%sm%apply(done,&
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
end if end if
case default case default
@ -1391,6 +1553,12 @@ contains
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
! and call recursively ! and call recursively
@ -1404,8 +1572,18 @@ contains
if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,&
& mlprec_wrk(level)%vy2l,done,mlprec_wrk(level)%vty,& & mlprec_wrk(level)%vy2l,done,mlprec_wrk(level)%vty,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
! !
@ -1417,7 +1595,7 @@ contains
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction') & a_err='Error during prolongation')
goto 9999 goto 9999
end if end if
@ -1427,6 +1605,11 @@ contains
call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
& done,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,& & done,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
! !
! Apply the base preconditioner ! Apply the base preconditioner
! !
@ -1441,7 +1624,7 @@ contains
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error: residual/baseprec_aply') & a_err='Error during smoother_apply')
goto 9999 goto 9999
end if end if

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

@ -488,7 +488,11 @@ contains
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
@ -565,13 +569,22 @@ contains
call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,&
& sone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,& & sone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps_post sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(sone,& call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,sone,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,sone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
@ -579,6 +592,11 @@ contains
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
end if end if
@ -615,7 +633,11 @@ contains
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
@ -624,7 +646,12 @@ contains
call psb_spmm(-sone,p%precv(level)%base_a,& call psb_spmm(-sone,p%precv(level)%base_a,&
& mlprec_wrk(level)%y2l,sone,mlprec_wrk(level)%x2l,& & mlprec_wrk(level)%y2l,sone,mlprec_wrk(level)%x2l,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) goto 9999
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -687,7 +714,11 @@ contains
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
@ -764,19 +795,35 @@ contains
call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,&
& sone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,& & sone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps_pre sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(sone,& call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,sone,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,sone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(sone,& call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
end if end if
case default case default
@ -827,6 +874,11 @@ contains
& mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
! and call recursively ! and call recursively
@ -836,6 +888,11 @@ contains
if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,&
& mlprec_wrk(level)%y2l,sone,mlprec_wrk(level)%ty,& & mlprec_wrk(level)%y2l,sone,mlprec_wrk(level)%ty,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -864,6 +921,11 @@ contains
call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,&
& sone,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,& & sone,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
! !
! Apply the base preconditioner ! Apply the base preconditioner
! !
@ -878,7 +940,7 @@ contains
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error: residual/baseprec_aply') & a_err='Error during smoother_apply')
goto 9999 goto 9999
end if end if
@ -1109,19 +1171,32 @@ contains
& mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
if (info /= psb_success_) goto 9999
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
! !
! Apply the prolongator ! Apply the prolongator
! !
call psb_map_Y2X(sone,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(sone,mlprec_wrk(level+1)%vy2l,&
& sone,mlprec_wrk(level)%vy2l,& & sone,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
end if end if
@ -1156,27 +1231,47 @@ contains
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
! !
! Apply the prolongator ! Apply the prolongator
! !
call psb_map_Y2X(sone,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(sone,mlprec_wrk(level+1)%vy2l,&
& szero,mlprec_wrk(level)%vy2l,& & szero,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
! !
! Compute the residual ! Compute the residual
! !
call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
& sone,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info,& & sone,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps_post sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(sone,& call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%vx2l,sone,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,sone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
@ -1184,6 +1279,11 @@ contains
& mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
end if end if
@ -1219,8 +1319,12 @@ contains
& mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
if (info /= psb_success_) goto 9999
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
@ -1229,14 +1333,28 @@ contains
call psb_spmm(-sone,p%precv(level)%base_a,& call psb_spmm(-sone,p%precv(level)%base_a,&
& mlprec_wrk(level)%vy2l,sone,mlprec_wrk(level)%vx2l,& & mlprec_wrk(level)%vy2l,sone,mlprec_wrk(level)%vx2l,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
call psb_map_Y2X(sone,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(sone,mlprec_wrk(level+1)%vy2l,&
& sone,mlprec_wrk(level)%vy2l,& & sone,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
end if end if
@ -1279,8 +1397,12 @@ contains
& mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
if (info /= psb_success_) goto 9999
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
@ -1289,14 +1411,29 @@ contains
call psb_spmm(-sone,p%precv(level)%base_a,& call psb_spmm(-sone,p%precv(level)%base_a,&
& mlprec_wrk(level)%vy2l,sone,mlprec_wrk(level)%vx2l,& & mlprec_wrk(level)%vy2l,sone,mlprec_wrk(level)%vx2l,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
call psb_map_Y2X(sone,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(sone,mlprec_wrk(level+1)%vy2l,&
& sone,mlprec_wrk(level)%vy2l,& & sone,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
end if end if
@ -1322,33 +1459,58 @@ contains
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
! !
! Apply the prolongator ! Apply the prolongator
! !
call psb_map_Y2X(sone,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(sone,mlprec_wrk(level+1)%vy2l,&
& szero,mlprec_wrk(level)%vy2l,& & szero,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
! !
! Compute the residual ! Compute the residual
! !
call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
& sone,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info,& & sone,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps_pre sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(sone,& call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%vx2l,sone,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,sone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(sone,& call p%precv(level)%sm%apply(sone,&
& mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
end if end if
case default case default
@ -1391,6 +1553,12 @@ contains
& mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
! and call recursively ! and call recursively
@ -1404,8 +1572,18 @@ contains
if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,&
& mlprec_wrk(level)%vy2l,sone,mlprec_wrk(level)%vty,& & mlprec_wrk(level)%vy2l,sone,mlprec_wrk(level)%vty,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
! !
@ -1417,7 +1595,7 @@ contains
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction') & a_err='Error during prolongation')
goto 9999 goto 9999
end if end if
@ -1427,6 +1605,11 @@ contains
call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
& sone,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,& & sone,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
! !
! Apply the base preconditioner ! Apply the base preconditioner
! !
@ -1441,7 +1624,7 @@ contains
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error: residual/baseprec_aply') & a_err='Error during smoother_apply')
goto 9999 goto 9999
end if end if

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

@ -488,7 +488,11 @@ contains
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
@ -565,13 +569,22 @@ contains
call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,&
& zone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,& & zone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps_post sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(zone,& call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%x2l,zone,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,zone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
@ -579,6 +592,11 @@ contains
& mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
end if end if
@ -615,7 +633,11 @@ contains
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
@ -624,7 +646,12 @@ contains
call psb_spmm(-zone,p%precv(level)%base_a,& call psb_spmm(-zone,p%precv(level)%base_a,&
& mlprec_wrk(level)%y2l,zone,mlprec_wrk(level)%x2l,& & mlprec_wrk(level)%y2l,zone,mlprec_wrk(level)%x2l,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) goto 9999
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -687,7 +714,11 @@ contains
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
@ -764,19 +795,35 @@ contains
call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,&
& zone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,& & zone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps_pre sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(zone,& call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%x2l,zone,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,zone,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(zone,& call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
end if end if
case default case default
@ -827,6 +874,11 @@ contains
& mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
! and call recursively ! and call recursively
@ -836,6 +888,11 @@ contains
if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,&
& mlprec_wrk(level)%y2l,zone,mlprec_wrk(level)%ty,& & mlprec_wrk(level)%y2l,zone,mlprec_wrk(level)%ty,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -864,6 +921,11 @@ contains
call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,&
& zone,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,& & zone,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
! !
! Apply the base preconditioner ! Apply the base preconditioner
! !
@ -878,7 +940,7 @@ contains
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error: residual/baseprec_aply') & a_err='Error during smoother_apply')
goto 9999 goto 9999
end if end if
@ -1109,19 +1171,32 @@ contains
& mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
if (info /= psb_success_) goto 9999
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
! !
! Apply the prolongator ! Apply the prolongator
! !
call psb_map_Y2X(zone,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(zone,mlprec_wrk(level+1)%vy2l,&
& zone,mlprec_wrk(level)%vy2l,& & zone,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
end if end if
@ -1156,27 +1231,47 @@ contains
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
! !
! Apply the prolongator ! Apply the prolongator
! !
call psb_map_Y2X(zone,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(zone,mlprec_wrk(level+1)%vy2l,&
& zzero,mlprec_wrk(level)%vy2l,& & zzero,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
! !
! Compute the residual ! Compute the residual
! !
call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
& zone,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info,& & zone,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps_post sweeps = p%precv(level)%parms%sweeps_post
call p%precv(level)%sm%apply(zone,& call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%vx2l,zone,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,zone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
@ -1184,6 +1279,11 @@ contains
& mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
end if end if
@ -1219,8 +1319,12 @@ contains
& mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
if (info /= psb_success_) goto 9999
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
@ -1229,14 +1333,28 @@ contains
call psb_spmm(-zone,p%precv(level)%base_a,& call psb_spmm(-zone,p%precv(level)%base_a,&
& mlprec_wrk(level)%vy2l,zone,mlprec_wrk(level)%vx2l,& & mlprec_wrk(level)%vy2l,zone,mlprec_wrk(level)%vx2l,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
call psb_map_Y2X(zone,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(zone,mlprec_wrk(level+1)%vy2l,&
& zone,mlprec_wrk(level)%vy2l,& & zone,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
end if end if
@ -1279,8 +1397,12 @@ contains
& mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
if (info /= psb_success_) goto 9999
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
@ -1289,14 +1411,29 @@ contains
call psb_spmm(-zone,p%precv(level)%base_a,& call psb_spmm(-zone,p%precv(level)%base_a,&
& mlprec_wrk(level)%vy2l,zone,mlprec_wrk(level)%vx2l,& & mlprec_wrk(level)%vy2l,zone,mlprec_wrk(level)%vx2l,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
call psb_map_Y2X(zone,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(zone,mlprec_wrk(level+1)%vy2l,&
& zone,mlprec_wrk(level)%vy2l,& & zone,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
end if end if
@ -1322,33 +1459,58 @@ contains
if (level < nlev) then if (level < nlev) then
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
! !
! Apply the prolongator ! Apply the prolongator
! !
call psb_map_Y2X(zone,mlprec_wrk(level+1)%vy2l,& call psb_map_Y2X(zone,mlprec_wrk(level+1)%vy2l,&
& zzero,mlprec_wrk(level)%vy2l,& & zzero,mlprec_wrk(level)%vy2l,&
& p%precv(level+1)%map,info,work=work) & p%precv(level+1)%map,info,work=work)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during prolongation')
goto 9999
end if
! !
! Compute the residual ! Compute the residual
! !
call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
& zone,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info,& & zone,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
sweeps = p%precv(level)%parms%sweeps_pre sweeps = p%precv(level)%parms%sweeps_pre
call p%precv(level)%sm%apply(zone,& call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%vx2l,zone,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,zone,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
else else
sweeps = p%precv(level)%parms%sweeps sweeps = p%precv(level)%parms%sweeps
call p%precv(level)%sm%apply(zone,& call p%precv(level)%sm%apply(zone,&
& mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
end if end if
case default case default
@ -1391,6 +1553,12 @@ contains
& mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,&
& p%precv(level)%base_desc, trans,& & p%precv(level)%base_desc, trans,&
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during smoother_apply')
goto 9999
end if
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
! and call recursively ! and call recursively
@ -1404,8 +1572,18 @@ contains
if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,&
& mlprec_wrk(level)%vy2l,zone,mlprec_wrk(level)%vty,& & mlprec_wrk(level)%vy2l,zone,mlprec_wrk(level)%vty,&
& p%precv(level)%base_desc,info,work=work,trans=trans) & p%precv(level)%base_desc,info,work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error in recursive call')
goto 9999
end if
! !
@ -1417,7 +1595,7 @@ contains
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during restriction') & a_err='Error during prolongation')
goto 9999 goto 9999
end if end if
@ -1427,6 +1605,11 @@ contains
call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
& zone,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,& & zone,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,&
& work=work,trans=trans) & work=work,trans=trans)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error during residue')
goto 9999
end if
! !
! Apply the base preconditioner ! Apply the base preconditioner
! !
@ -1441,7 +1624,7 @@ contains
& sweeps,work,info) & sweeps,work,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
& a_err='Error: residual/baseprec_aply') & a_err='Error during smoother_apply')
goto 9999 goto 9999
end if end if

Write Preview
Loading…
Cancel
Save