From 3d6537ed217b3c77d34881e90982740be33c1fad Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sat, 31 Aug 2013 15:24:22 +0000 Subject: [PATCH] mld2p4-299 Fixes for integer vecors in DESC (even inside maps) Added imold to interface. Implementation is still incomplete. --- mlprec/impl/mld_cmlprec_aply.f90 | 83 ++++++++++++++++++++++++----- mlprec/impl/mld_cmlprec_bld.f90 | 3 +- mlprec/impl/mld_cprecbld.f90 | 3 +- mlprec/impl/mld_dmlprec_aply.f90 | 89 ++++++++++++++++++++++---------- mlprec/impl/mld_dmlprec_bld.f90 | 23 ++------- mlprec/impl/mld_dprecbld.f90 | 34 ++++++------ mlprec/impl/mld_smlprec_aply.f90 | 83 ++++++++++++++++++++++++----- mlprec/impl/mld_smlprec_bld.f90 | 3 +- mlprec/impl/mld_sprecbld.f90 | 3 +- mlprec/impl/mld_zmlprec_aply.f90 | 83 ++++++++++++++++++++++++----- mlprec/impl/mld_zmlprec_bld.f90 | 3 +- mlprec/impl/mld_zprecbld.f90 | 3 +- mlprec/mld_c_inner_mod.f90 | 5 +- mlprec/mld_c_prec_mod.f90 | 5 +- mlprec/mld_s_inner_mod.f90 | 5 +- mlprec/mld_s_prec_mod.f90 | 5 +- mlprec/mld_z_inner_mod.f90 | 5 +- mlprec/mld_z_prec_mod.f90 | 5 +- tests/pdegen/runs/ppde.inp | 4 +- 19 files changed, 320 insertions(+), 127 deletions(-) diff --git a/mlprec/impl/mld_cmlprec_aply.f90 b/mlprec/impl/mld_cmlprec_aply.f90 index eeb9d199..8d9efc9d 100644 --- a/mlprec/impl/mld_cmlprec_aply.f90 +++ b/mlprec/impl/mld_cmlprec_aply.f90 @@ -488,18 +488,26 @@ contains & p%precv(level)%base_desc, trans,& & sweeps,work,info) - if (info /= psb_success_) goto 9999 + if (level < nlev) then 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 ! call psb_map_Y2X(cone,mlprec_wrk(level+1)%y2l,& & cone,mlprec_wrk(level)%y2l,& & 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 @@ -534,14 +542,23 @@ contains if (level < nlev) then 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 ! call psb_map_Y2X(cone,mlprec_wrk(level+1)%y2l,& & czero,mlprec_wrk(level)%y2l,& & 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 ! @@ -608,13 +625,25 @@ contains & mlprec_wrk(level)%y2l,cone,mlprec_wrk(level)%x2l,& & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) goto 9999 + 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)%y2l,& & cone,mlprec_wrk(level)%y2l,& & 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 @@ -669,12 +698,23 @@ contains & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) goto 9999 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)%y2l,& & cone,mlprec_wrk(level)%y2l,& & 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 @@ -700,14 +740,24 @@ contains if (level < nlev) then 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 ! call psb_map_Y2X(cone,mlprec_wrk(level+1)%y2l,& & czero,mlprec_wrk(level)%y2l,& & 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 ! @@ -788,6 +838,11 @@ contains & p%precv(level)%base_desc,info,work=work,trans=trans) 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 ! @@ -796,10 +851,10 @@ contains call psb_map_Y2X(cone,mlprec_wrk(level+1)%y2l,& & cone,mlprec_wrk(level)%y2l,& & p%precv(level+1)%map,info,work=work) - - if (info /= psb_success_ ) then + + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') + & a_err='Error during prolongation') goto 9999 end if diff --git a/mlprec/impl/mld_cmlprec_bld.f90 b/mlprec/impl/mld_cmlprec_bld.f90 index 8a468317..adcf6aae 100644 --- a/mlprec/impl/mld_cmlprec_bld.f90 +++ b/mlprec/impl/mld_cmlprec_bld.f90 @@ -74,7 +74,7 @@ ! ! ! -subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) +subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold,imold) use psb_base_mod use mld_c_inner_mod, mld_protect_name => mld_cmlprec_bld @@ -89,6 +89,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) integer(psb_ipk_), intent(out) :: info class(psb_c_base_sparse_mat), intent(in), optional :: amold class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in), optional :: upd ! Local Variables diff --git a/mlprec/impl/mld_cprecbld.f90 b/mlprec/impl/mld_cprecbld.f90 index bac8b1b5..61ced362 100644 --- a/mlprec/impl/mld_cprecbld.f90 +++ b/mlprec/impl/mld_cprecbld.f90 @@ -58,7 +58,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_cprecbld(a,desc_a,p,info,amold,vmold) +subroutine mld_cprecbld(a,desc_a,p,info,amold,vmold,imold) use psb_base_mod use mld_c_inner_mod @@ -73,6 +73,7 @@ subroutine mld_cprecbld(a,desc_a,p,info,amold,vmold) integer(psb_ipk_), intent(out) :: info class(psb_c_base_sparse_mat), intent(in), optional :: amold class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in), optional :: upd ! Local Variables diff --git a/mlprec/impl/mld_dmlprec_aply.f90 b/mlprec/impl/mld_dmlprec_aply.f90 index d79f23f0..2af6eb64 100644 --- a/mlprec/impl/mld_dmlprec_aply.f90 +++ b/mlprec/impl/mld_dmlprec_aply.f90 @@ -362,8 +362,7 @@ subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) nr2l = p%precv(level)%base_desc%get_local_rows() allocate(mlprec_wrk(level)%x2l(nc2l),mlprec_wrk(level)%y2l(nc2l),& & stat=info) - if (info /= psb_success_) then - write(0,*) 'Allocation Error at level ',0 + if (info /= psb_success_) then info=psb_err_alloc_request_ call psb_errpush(info,name,& & i_err=(/ione*(size(x)+size(y)),izero,izero,izero,izero/),& @@ -447,7 +446,6 @@ contains & mlprec_wrk(level)%y2l(nc2l),& & stat=info) if (info /= psb_success_) then - write(0,*) 'Allocation Error at level',level, nc2l info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& & a_err='real(psb_dpk_)') @@ -490,18 +488,26 @@ contains & p%precv(level)%base_desc, trans,& & sweeps,work,info) - if (info /= psb_success_) goto 9999 + if (level < nlev) then 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 ! call psb_map_Y2X(done,mlprec_wrk(level+1)%y2l,& & done,mlprec_wrk(level)%y2l,& & 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 @@ -524,7 +530,7 @@ contains call psb_map_X2Y(done,mlprec_wrk(level-1)%x2l,& & dzero,mlprec_wrk(level)%x2l,& & p%precv(level)%map,info,work=work) -!!$ write(0,*) 'inner_ml map_x2y :',level,info + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') @@ -619,13 +625,25 @@ contains & mlprec_wrk(level)%y2l,done,mlprec_wrk(level)%x2l,& & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) goto 9999 + 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)%y2l,& & done,mlprec_wrk(level)%y2l,& & 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 @@ -680,12 +698,23 @@ contains & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) goto 9999 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)%y2l,& & done,mlprec_wrk(level)%y2l,& & 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 @@ -711,14 +740,24 @@ contains if (level < nlev) then 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 ! call psb_map_Y2X(done,mlprec_wrk(level+1)%y2l,& & dzero,mlprec_wrk(level)%y2l,& & 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 ! @@ -799,6 +838,11 @@ contains & p%precv(level)%base_desc,info,work=work,trans=trans) 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 ! @@ -807,10 +851,10 @@ contains call psb_map_Y2X(done,mlprec_wrk(level+1)%y2l,& & done,mlprec_wrk(level)%y2l,& & p%precv(level+1)%map,info,work=work) - - if (info /= psb_success_ ) then + + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') + & a_err='Error during prolongation') goto 9999 end if @@ -937,7 +981,6 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) if (psb_errstatus_fatal()) then nc2l = p%precv(level)%base_desc%get_local_cols() info=psb_err_alloc_request_ - write(0,*) 'Allocation Error at level ',0 call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& & a_err='real(psb_dpk_)') goto 9999 @@ -1101,7 +1144,7 @@ contains call psb_map_X2Y(done,mlprec_wrk(level-1)%vx2l,& & dzero,mlprec_wrk(level)%vx2l,& & p%precv(level)%map,info,work=work) -!!$ write(0,*) 'inner_ml map_x2y :',level,info + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') @@ -1113,11 +1156,6 @@ contains if (level < nlev) then 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 if (info /= psb_success_) goto 9999 ! ! Apply the prolongator @@ -1125,11 +1163,6 @@ contains call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& & dzero,mlprec_wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during prolongation') - goto 9999 - end if if (info /= psb_success_) goto 9999 ! ! Compute the residual diff --git a/mlprec/impl/mld_dmlprec_bld.f90 b/mlprec/impl/mld_dmlprec_bld.f90 index dfa16fc9..16641ff4 100644 --- a/mlprec/impl/mld_dmlprec_bld.f90 +++ b/mlprec/impl/mld_dmlprec_bld.f90 @@ -74,7 +74,7 @@ ! ! ! -subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) +subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold,imold) use psb_base_mod use mld_d_inner_mod, mld_protect_name => mld_dmlprec_bld @@ -89,6 +89,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) integer(psb_ipk_), intent(out) :: info class(psb_d_base_sparse_mat), intent(in), optional :: amold class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in), optional :: upd ! Local Variables @@ -175,7 +176,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) endif -!!$ write(0,*) 'DMLPRECBLD: CASIZE ',casize + if (casize>0) then ! ! New strategy to build according to coarse size. @@ -291,11 +292,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) current => newnode ! First do a move_alloc. ! This handles the AC, DESC_AC and MAP fields -!!$ associate(this=>current%item%map) -!!$ if (i>1) write(0,*) 'List realloc loop input:',i,& -!!$ & allocated(this%p_desc_X%v_halo_index%v),& -!!$ & allocated(this%p_desc_Y%v_halo_index%v) -!!$ end associate if (info == psb_success_) & & call mld_move_alloc(current%item,p%precv(i),info) ! Now set the smoother/solver parts. @@ -325,11 +321,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc end if -!!$ associate(this =>p%precv(i)%map) -!!$ if (i>1) write(0,*) 'List realloc loop output:',i,& -!!$ & allocated(this%p_desc_X%v_halo_index%v),& -!!$ & allocated(this%p_desc_Y%v_halo_index%v) -!!$ end associate newnode => current%next deallocate(current) @@ -511,14 +502,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Return from ',i,' call to mlprcbld ',info - -!!$ associate(this =>p%precv(i)%map) -!!$ if (i>1) write(0,*) 'After sm build at level:',i,& -!!$ & allocated(this%p_desc_X%v_halo_index%v),& -!!$ & allocated(this%p_desc_Y%v_halo_index%v) -!!$ end associate - - end do diff --git a/mlprec/impl/mld_dprecbld.f90 b/mlprec/impl/mld_dprecbld.f90 index c3efec5c..938b3277 100644 --- a/mlprec/impl/mld_dprecbld.f90 +++ b/mlprec/impl/mld_dprecbld.f90 @@ -165,22 +165,22 @@ subroutine mld_dprecbld(a,desc_a,p,info,amold,vmold,imold) call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') goto 9999 end if - - call p%precv(1)%check(info) - if (info /= psb_success_) then - write(0,*) ' Smoother check error',info - call psb_errpush(psb_err_internal_error_,name,& - & a_err='One level preconditioner check.') - goto 9999 - endif - - call p%precv(1)%sm%build(a,desc_a,upd_,info,amold=amold,vmold=vmold) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='One level preconditioner build.') - goto 9999 - endif - + + call p%precv(1)%check(info) + if (info /= psb_success_) then + write(0,*) ' Smoother check error',info + call psb_errpush(psb_err_internal_error_,name,& + & a_err='One level preconditioner check.') + goto 9999 + endif + + call p%precv(1)%sm%build(a,desc_a,upd_,info,amold=amold,vmold=vmold) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='One level preconditioner build.') + goto 9999 + endif + ! ! Number of levels > 1 ! @@ -189,7 +189,7 @@ subroutine mld_dprecbld(a,desc_a,p,info,amold,vmold,imold) ! Build the multilevel preconditioner ! call mld_mlprec_bld(a,desc_a,p,info,amold=amold,vmold=vmold) - + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Multilevel preconditioner build.') diff --git a/mlprec/impl/mld_smlprec_aply.f90 b/mlprec/impl/mld_smlprec_aply.f90 index b5ef086e..4351316d 100644 --- a/mlprec/impl/mld_smlprec_aply.f90 +++ b/mlprec/impl/mld_smlprec_aply.f90 @@ -488,18 +488,26 @@ contains & p%precv(level)%base_desc, trans,& & sweeps,work,info) - if (info /= psb_success_) goto 9999 + if (level < nlev) then 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 ! call psb_map_Y2X(sone,mlprec_wrk(level+1)%y2l,& & sone,mlprec_wrk(level)%y2l,& & 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 @@ -534,14 +542,23 @@ contains if (level < nlev) then 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 ! call psb_map_Y2X(sone,mlprec_wrk(level+1)%y2l,& & szero,mlprec_wrk(level)%y2l,& & 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 ! @@ -608,13 +625,25 @@ contains & mlprec_wrk(level)%y2l,sone,mlprec_wrk(level)%x2l,& & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) goto 9999 + 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)%y2l,& & sone,mlprec_wrk(level)%y2l,& & 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 @@ -669,12 +698,23 @@ contains & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) goto 9999 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)%y2l,& & sone,mlprec_wrk(level)%y2l,& & 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 @@ -700,14 +740,24 @@ contains if (level < nlev) then 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 ! call psb_map_Y2X(sone,mlprec_wrk(level+1)%y2l,& & szero,mlprec_wrk(level)%y2l,& & 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 ! @@ -788,6 +838,11 @@ contains & p%precv(level)%base_desc,info,work=work,trans=trans) 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 ! @@ -796,10 +851,10 @@ contains call psb_map_Y2X(sone,mlprec_wrk(level+1)%y2l,& & sone,mlprec_wrk(level)%y2l,& & p%precv(level+1)%map,info,work=work) - - if (info /= psb_success_ ) then + + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') + & a_err='Error during prolongation') goto 9999 end if diff --git a/mlprec/impl/mld_smlprec_bld.f90 b/mlprec/impl/mld_smlprec_bld.f90 index 7de96428..205c13e5 100644 --- a/mlprec/impl/mld_smlprec_bld.f90 +++ b/mlprec/impl/mld_smlprec_bld.f90 @@ -74,7 +74,7 @@ ! ! ! -subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) +subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold,imold) use psb_base_mod use mld_s_inner_mod, mld_protect_name => mld_smlprec_bld @@ -89,6 +89,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) integer(psb_ipk_), intent(out) :: info class(psb_s_base_sparse_mat), intent(in), optional :: amold class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in), optional :: upd ! Local Variables diff --git a/mlprec/impl/mld_sprecbld.f90 b/mlprec/impl/mld_sprecbld.f90 index 5a74525e..5b3c5d33 100644 --- a/mlprec/impl/mld_sprecbld.f90 +++ b/mlprec/impl/mld_sprecbld.f90 @@ -58,7 +58,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_sprecbld(a,desc_a,p,info,amold,vmold) +subroutine mld_sprecbld(a,desc_a,p,info,amold,vmold,imold) use psb_base_mod use mld_s_inner_mod @@ -73,6 +73,7 @@ subroutine mld_sprecbld(a,desc_a,p,info,amold,vmold) integer(psb_ipk_), intent(out) :: info class(psb_s_base_sparse_mat), intent(in), optional :: amold class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in), optional :: upd ! Local Variables diff --git a/mlprec/impl/mld_zmlprec_aply.f90 b/mlprec/impl/mld_zmlprec_aply.f90 index a02962f6..a674656d 100644 --- a/mlprec/impl/mld_zmlprec_aply.f90 +++ b/mlprec/impl/mld_zmlprec_aply.f90 @@ -488,18 +488,26 @@ contains & p%precv(level)%base_desc, trans,& & sweeps,work,info) - if (info /= psb_success_) goto 9999 + if (level < nlev) then 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 ! call psb_map_Y2X(zone,mlprec_wrk(level+1)%y2l,& & zone,mlprec_wrk(level)%y2l,& & 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 @@ -534,14 +542,23 @@ contains if (level < nlev) then 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 ! call psb_map_Y2X(zone,mlprec_wrk(level+1)%y2l,& & zzero,mlprec_wrk(level)%y2l,& & 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 ! @@ -608,13 +625,25 @@ contains & mlprec_wrk(level)%y2l,zone,mlprec_wrk(level)%x2l,& & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) goto 9999 + 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)%y2l,& & zone,mlprec_wrk(level)%y2l,& & 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 @@ -669,12 +698,23 @@ contains & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) goto 9999 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)%y2l,& & zone,mlprec_wrk(level)%y2l,& & 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 @@ -700,14 +740,24 @@ contains if (level < nlev) then 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 ! call psb_map_Y2X(zone,mlprec_wrk(level+1)%y2l,& & zzero,mlprec_wrk(level)%y2l,& & 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 ! @@ -788,6 +838,11 @@ contains & p%precv(level)%base_desc,info,work=work,trans=trans) 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 ! @@ -796,10 +851,10 @@ contains call psb_map_Y2X(zone,mlprec_wrk(level+1)%y2l,& & zone,mlprec_wrk(level)%y2l,& & p%precv(level+1)%map,info,work=work) - - if (info /= psb_success_ ) then + + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') + & a_err='Error during prolongation') goto 9999 end if diff --git a/mlprec/impl/mld_zmlprec_bld.f90 b/mlprec/impl/mld_zmlprec_bld.f90 index 62d58a1d..e66a4917 100644 --- a/mlprec/impl/mld_zmlprec_bld.f90 +++ b/mlprec/impl/mld_zmlprec_bld.f90 @@ -74,7 +74,7 @@ ! ! ! -subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) +subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold,imold) use psb_base_mod use mld_z_inner_mod, mld_protect_name => mld_zmlprec_bld @@ -89,6 +89,7 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) integer(psb_ipk_), intent(out) :: info class(psb_z_base_sparse_mat), intent(in), optional :: amold class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in), optional :: upd ! Local Variables diff --git a/mlprec/impl/mld_zprecbld.f90 b/mlprec/impl/mld_zprecbld.f90 index 98fbf73c..1cda521f 100644 --- a/mlprec/impl/mld_zprecbld.f90 +++ b/mlprec/impl/mld_zprecbld.f90 @@ -58,7 +58,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_zprecbld(a,desc_a,p,info,amold,vmold) +subroutine mld_zprecbld(a,desc_a,p,info,amold,vmold,imold) use psb_base_mod use mld_z_inner_mod @@ -73,6 +73,7 @@ subroutine mld_zprecbld(a,desc_a,p,info,amold,vmold) integer(psb_ipk_), intent(out) :: info class(psb_z_base_sparse_mat), intent(in), optional :: amold class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in), optional :: upd ! Local Variables diff --git a/mlprec/mld_c_inner_mod.f90 b/mlprec/mld_c_inner_mod.f90 index 27dd4e1e..4b1c4530 100644 --- a/mlprec/mld_c_inner_mod.f90 +++ b/mlprec/mld_c_inner_mod.f90 @@ -48,8 +48,8 @@ module mld_c_inner_mod use mld_c_prec_type interface mld_mlprec_bld - subroutine mld_cmlprec_bld(a,desc_a,prec,info, amold, vmold) - use psb_base_mod, only : psb_cspmat_type, psb_desc_type, & + subroutine mld_cmlprec_bld(a,desc_a,prec,info, amold, vmold,imold) + use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_i_base_vect_type, & & psb_spk_, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_ use mld_c_prec_type, only : mld_cprec_type implicit none @@ -59,6 +59,7 @@ module mld_c_inner_mod integer(psb_ipk_), intent(out) :: info class(psb_c_base_sparse_mat), intent(in), optional :: amold class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in),optional :: upd end subroutine mld_cmlprec_bld end interface mld_mlprec_bld diff --git a/mlprec/mld_c_prec_mod.f90 b/mlprec/mld_c_prec_mod.f90 index 39422657..28c3550a 100644 --- a/mlprec/mld_c_prec_mod.f90 +++ b/mlprec/mld_c_prec_mod.f90 @@ -72,10 +72,10 @@ module mld_c_prec_mod !!$ interface mld_inner_precset interface mld_precbld - subroutine mld_cprecbld(a,desc_a,prec,info,amold,vmold) + subroutine mld_cprecbld(a,desc_a,prec,info,amold,vmold,imold) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & psb_c_base_sparse_mat, psb_c_base_vect_type, & - & mld_cprec_type, psb_ipk_ + & psb_i_base_vect_type, mld_cprec_type, psb_ipk_ implicit none type(psb_cspmat_type), intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a @@ -83,6 +83,7 @@ module mld_c_prec_mod integer(psb_ipk_), intent(out) :: info class(psb_c_base_sparse_mat), intent(in), optional :: amold class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in),optional :: upd end subroutine mld_cprecbld end interface diff --git a/mlprec/mld_s_inner_mod.f90 b/mlprec/mld_s_inner_mod.f90 index 5e5b74e9..4991bc83 100644 --- a/mlprec/mld_s_inner_mod.f90 +++ b/mlprec/mld_s_inner_mod.f90 @@ -48,8 +48,8 @@ module mld_s_inner_mod use mld_s_prec_type interface mld_mlprec_bld - subroutine mld_smlprec_bld(a,desc_a,prec,info, amold, vmold) - use psb_base_mod, only : psb_sspmat_type, psb_desc_type, & + subroutine mld_smlprec_bld(a,desc_a,prec,info, amold, vmold,imold) + use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_i_base_vect_type, & & psb_spk_, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_ use mld_s_prec_type, only : mld_sprec_type implicit none @@ -59,6 +59,7 @@ module mld_s_inner_mod integer(psb_ipk_), intent(out) :: info class(psb_s_base_sparse_mat), intent(in), optional :: amold class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in),optional :: upd end subroutine mld_smlprec_bld end interface mld_mlprec_bld diff --git a/mlprec/mld_s_prec_mod.f90 b/mlprec/mld_s_prec_mod.f90 index 5ee8876d..468f7525 100644 --- a/mlprec/mld_s_prec_mod.f90 +++ b/mlprec/mld_s_prec_mod.f90 @@ -72,10 +72,10 @@ module mld_s_prec_mod !!$ interface mld_inner_precset interface mld_precbld - subroutine mld_sprecbld(a,desc_a,prec,info,amold,vmold) + subroutine mld_sprecbld(a,desc_a,prec,info,amold,vmold,imold) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & psb_s_base_sparse_mat, psb_s_base_vect_type, & - & mld_sprec_type, psb_ipk_ + & psb_i_base_vect_type, mld_sprec_type, psb_ipk_ implicit none type(psb_sspmat_type), intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a @@ -83,6 +83,7 @@ module mld_s_prec_mod integer(psb_ipk_), intent(out) :: info class(psb_s_base_sparse_mat), intent(in), optional :: amold class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in),optional :: upd end subroutine mld_sprecbld end interface diff --git a/mlprec/mld_z_inner_mod.f90 b/mlprec/mld_z_inner_mod.f90 index eeb96c36..d42d950e 100644 --- a/mlprec/mld_z_inner_mod.f90 +++ b/mlprec/mld_z_inner_mod.f90 @@ -48,8 +48,8 @@ module mld_z_inner_mod use mld_z_prec_type interface mld_mlprec_bld - subroutine mld_zmlprec_bld(a,desc_a,prec,info, amold, vmold) - use psb_base_mod, only : psb_zspmat_type, psb_desc_type, & + subroutine mld_zmlprec_bld(a,desc_a,prec,info, amold, vmold,imold) + use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_i_base_vect_type, & & psb_dpk_, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_ use mld_z_prec_type, only : mld_zprec_type implicit none @@ -59,6 +59,7 @@ module mld_z_inner_mod integer(psb_ipk_), intent(out) :: info class(psb_z_base_sparse_mat), intent(in), optional :: amold class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in),optional :: upd end subroutine mld_zmlprec_bld end interface mld_mlprec_bld diff --git a/mlprec/mld_z_prec_mod.f90 b/mlprec/mld_z_prec_mod.f90 index 3f46f420..dd409a59 100644 --- a/mlprec/mld_z_prec_mod.f90 +++ b/mlprec/mld_z_prec_mod.f90 @@ -72,10 +72,10 @@ module mld_z_prec_mod !!$ interface mld_inner_precset interface mld_precbld - subroutine mld_zprecbld(a,desc_a,prec,info,amold,vmold) + subroutine mld_zprecbld(a,desc_a,prec,info,amold,vmold,imold) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & psb_z_base_sparse_mat, psb_z_base_vect_type, & - & mld_zprec_type, psb_ipk_ + & psb_i_base_vect_type, mld_zprec_type, psb_ipk_ implicit none type(psb_zspmat_type), intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a @@ -83,6 +83,7 @@ module mld_z_prec_mod integer(psb_ipk_), intent(out) :: info class(psb_z_base_sparse_mat), intent(in), optional :: amold class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold !!$ character, intent(in),optional :: upd end subroutine mld_zprecbld end interface diff --git a/tests/pdegen/runs/ppde.inp b/tests/pdegen/runs/ppde.inp index ed156384..35add26d 100644 --- a/tests/pdegen/runs/ppde.inp +++ b/tests/pdegen/runs/ppde.inp @@ -7,8 +7,8 @@ CSR ! Storage format CSR COO JAD 30 ! IRST (restart for RGMRES and BiCGSTABL) 1.d-6 ! EPS 3L-MUL-RAS-BJAC4-ILU ! Descriptive name for preconditioner (up to 40 chars) -ML ! Preconditioner NONE JACOBI BJAC AS ML -1 ! Number of overlap layers for AS preconditioner at finest level +AS ! Preconditioner NONE JACOBI BJAC AS ML +2 ! Number of overlap layers for AS preconditioner at finest level HALO ! Restriction operator NONE HALO NONE ! Prolongation operator NONE SUM AVG ILU ! Subdomain solver DSCALE ILU MILU ILUT UMF SLU