From 21e38e140c3c4b8ab2342d38b4629f994046fbf9 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sat, 31 Aug 2013 12:14:44 +0000 Subject: [PATCH] mld2p4-299: Check for new descriptor integer vectors. Will need to revise the errors in mlprecaply --- mlprec/impl/mld_daggrmat_asb.f90 | 5 ++++- mlprec/impl/mld_dmlprec_aply.f90 | 32 ++++++++++++++++++++++----- mlprec/impl/mld_dmlprec_bld.f90 | 20 ++++++++++++++++- mlprec/impl/mld_dprecbld.f90 | 37 ++++++++++++++++---------------- mlprec/mld_base_prec_type.F90 | 2 +- mlprec/mld_d_inner_mod.f90 | 5 +++-- mlprec/mld_d_prec_mod.f90 | 5 +++-- 7 files changed, 76 insertions(+), 30 deletions(-) diff --git a/mlprec/impl/mld_daggrmat_asb.f90 b/mlprec/impl/mld_daggrmat_asb.f90 index eae29e93..57533916 100644 --- a/mlprec/impl/mld_daggrmat_asb.f90 +++ b/mlprec/impl/mld_daggrmat_asb.f90 @@ -259,7 +259,10 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) ! op_restr => PR^T i.e. restriction operator ! op_prol => PR i.e. prolongation operator ! - +!!$ write(0,*) 'allocated DSC_AC ',allocated(p%desc_ac%v_halo_index%v),& +!!$ & allocated(p%desc_ac%v_ext_index%v),& +!!$ & allocated(p%desc_ac%v_ovrlap_index%v),& +!!$ &allocated(p%desc_ac%v_ovr_mst_idx%v) p%map = psb_linmap(psb_map_aggr_,desc_a,& & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) if (info == psb_success_) call op_prol%free() diff --git a/mlprec/impl/mld_dmlprec_aply.f90 b/mlprec/impl/mld_dmlprec_aply.f90 index 5333f556..d79f23f0 100644 --- a/mlprec/impl/mld_dmlprec_aply.f90 +++ b/mlprec/impl/mld_dmlprec_aply.f90 @@ -362,7 +362,8 @@ 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 + if (info /= psb_success_) then + write(0,*) 'Allocation Error at level ',0 info=psb_err_alloc_request_ call psb_errpush(info,name,& & i_err=(/ione*(size(x)+size(y)),izero,izero,izero,izero/),& @@ -446,6 +447,7 @@ 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_)') @@ -522,7 +524,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') @@ -534,14 +536,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(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 ! @@ -926,6 +937,7 @@ 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 @@ -1089,7 +1101,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') @@ -1101,6 +1113,11 @@ 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 @@ -1108,6 +1125,11 @@ 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 f408d49d..dfa16fc9 100644 --- a/mlprec/impl/mld_dmlprec_bld.f90 +++ b/mlprec/impl/mld_dmlprec_bld.f90 @@ -175,7 +175,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,6 +291,11 @@ 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. @@ -320,6 +325,11 @@ 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) @@ -501,6 +511,14 @@ 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 1e1de152..c3efec5c 100644 --- a/mlprec/impl/mld_dprecbld.f90 +++ b/mlprec/impl/mld_dprecbld.f90 @@ -58,7 +58,7 @@ ! info - integer, output. ! Error code. ! -subroutine mld_dprecbld(a,desc_a,p,info,amold,vmold) +subroutine mld_dprecbld(a,desc_a,p,info,amold,vmold,imold) use psb_base_mod use mld_d_inner_mod @@ -73,6 +73,7 @@ subroutine mld_dprecbld(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 @@ -164,22 +165,22 @@ subroutine mld_dprecbld(a,desc_a,p,info,amold,vmold) 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 ! @@ -188,7 +189,7 @@ subroutine mld_dprecbld(a,desc_a,p,info,amold,vmold) ! 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/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index f6de2cd4..b85daffc 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -65,7 +65,7 @@ module mld_base_prec_type ! use psb_const_mod use psb_base_mod, only :& - & psb_desc_type,& + & psb_desc_type, psb_i_vect_type, psb_i_base_vect_type,& & psb_ipk_, psb_dpk_, psb_spk_, psb_long_int_k_, & & psb_cdfree, psb_halo_, psb_none_, psb_sum_, psb_avg_, & & psb_nohalo_, psb_square_root_, psb_toupper, psb_root_,& diff --git a/mlprec/mld_d_inner_mod.f90 b/mlprec/mld_d_inner_mod.f90 index 0c3d8169..e6d165e4 100644 --- a/mlprec/mld_d_inner_mod.f90 +++ b/mlprec/mld_d_inner_mod.f90 @@ -48,8 +48,8 @@ module mld_d_inner_mod use mld_d_prec_type interface mld_mlprec_bld - subroutine mld_dmlprec_bld(a,desc_a,prec,info, amold, vmold) - use psb_base_mod, only : psb_dspmat_type, psb_desc_type, & + subroutine mld_dmlprec_bld(a,desc_a,prec,info, amold, vmold,imold) + use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_i_base_vect_type, & & psb_dpk_, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_ use mld_d_prec_type, only : mld_dprec_type implicit none @@ -59,6 +59,7 @@ module mld_d_inner_mod 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 end subroutine mld_dmlprec_bld end interface mld_mlprec_bld diff --git a/mlprec/mld_d_prec_mod.f90 b/mlprec/mld_d_prec_mod.f90 index e637f428..03232ff9 100644 --- a/mlprec/mld_d_prec_mod.f90 +++ b/mlprec/mld_d_prec_mod.f90 @@ -72,10 +72,10 @@ module mld_d_prec_mod !!$ interface mld_inner_precset interface mld_precbld - subroutine mld_dprecbld(a,desc_a,prec,info,amold,vmold) + subroutine mld_dprecbld(a,desc_a,prec,info,amold,vmold,imold) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & psb_d_base_sparse_mat, psb_d_base_vect_type, & - & mld_dprec_type, psb_ipk_ + & psb_i_base_vect_type, mld_dprec_type, psb_ipk_ implicit none type(psb_dspmat_type), intent(in), target :: a type(psb_desc_type), intent(inout), target :: desc_a @@ -83,6 +83,7 @@ module mld_d_prec_mod 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 end subroutine mld_dprecbld end interface