diff --git a/mlprec/impl/mld_cmlprec_aply.f90 b/mlprec/impl/mld_cmlprec_aply.f90 index 3ba3d8c4..3a961b37 100644 --- a/mlprec/impl/mld_cmlprec_aply.f90 +++ b/mlprec/impl/mld_cmlprec_aply.f90 @@ -244,7 +244,7 @@ subroutine mld_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) trans_ = psb_toupper(trans) nlev = size(p%precv) - do_alloc_wrk = .not.allocated(p%wrk) + do_alloc_wrk = .not.allocated(p%precv(1)%wrk) if (do_alloc_wrk) call p%allocate_wrk(info,vmold=x%v) if (info /= psb_success_) then diff --git a/mlprec/impl/mld_cprecaply.f90 b/mlprec/impl/mld_cprecaply.f90 index 3641d26e..73bd7796 100644 --- a/mlprec/impl/mld_cprecaply.f90 +++ b/mlprec/impl/mld_cprecaply.f90 @@ -360,7 +360,7 @@ subroutine mld_cprecaply2_vect(prec,x,y,desc_data,info,trans,work) goto 9999 end if - do_alloc_wrk = .not.allocated(prec%wrk) + do_alloc_wrk = .not.allocated(prec%precv(1)%wrk) if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) if (size(prec%precv) >1) then @@ -501,11 +501,11 @@ subroutine mld_cprecaply1_vect(prec,x,desc_data,info,trans,work) goto 9999 end if - do_alloc_wrk = .not.allocated(prec%wrk) + do_alloc_wrk = .not.allocated(prec%precv(1)%wrk) if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) associate(ww => prec%precv(1)%wrk%vtx, wv => prec%precv(1)%wrk%wv) - call psb_geasb(ww,desc_data,info,mold=x%v,scratch=.true.) + if (size(prec%precv) >1) then ! ! Number of levels > 1: apply the multilevel preconditioner @@ -561,11 +561,11 @@ subroutine mld_cprecaply1_vect(prec,x,desc_data,info,trans,work) goto 9999 endif end associate -!!$ if (info == 0) call psb_gefree(ww,desc_data,info) ! If the original distribution has an overlap we should fix that. call psb_halo(x,desc_data,info,data=psb_comm_mov_) + if (do_alloc_wrk) call prec%free_wrk(info) if (present(work)) then else diff --git a/mlprec/impl/mld_dmlprec_aply.f90 b/mlprec/impl/mld_dmlprec_aply.f90 index e7d74c11..94d0bec5 100644 --- a/mlprec/impl/mld_dmlprec_aply.f90 +++ b/mlprec/impl/mld_dmlprec_aply.f90 @@ -244,7 +244,7 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) trans_ = psb_toupper(trans) nlev = size(p%precv) - do_alloc_wrk = .not.allocated(p%wrk) + do_alloc_wrk = .not.allocated(p%precv(1)%wrk) if (do_alloc_wrk) call p%allocate_wrk(info,vmold=x%v) if (info /= psb_success_) then diff --git a/mlprec/impl/mld_dprecaply.f90 b/mlprec/impl/mld_dprecaply.f90 index d9277daf..d6efd657 100644 --- a/mlprec/impl/mld_dprecaply.f90 +++ b/mlprec/impl/mld_dprecaply.f90 @@ -360,7 +360,7 @@ subroutine mld_dprecaply2_vect(prec,x,y,desc_data,info,trans,work) goto 9999 end if - do_alloc_wrk = .not.allocated(prec%wrk) + do_alloc_wrk = .not.allocated(prec%precv(1)%wrk) if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) if (size(prec%precv) >1) then @@ -501,11 +501,11 @@ subroutine mld_dprecaply1_vect(prec,x,desc_data,info,trans,work) goto 9999 end if - do_alloc_wrk = .not.allocated(prec%wrk) + do_alloc_wrk = .not.allocated(prec%precv(1)%wrk) if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) associate(ww => prec%precv(1)%wrk%vtx, wv => prec%precv(1)%wrk%wv) - call psb_geasb(ww,desc_data,info,mold=x%v,scratch=.true.) + if (size(prec%precv) >1) then ! ! Number of levels > 1: apply the multilevel preconditioner @@ -561,11 +561,11 @@ subroutine mld_dprecaply1_vect(prec,x,desc_data,info,trans,work) goto 9999 endif end associate -!!$ if (info == 0) call psb_gefree(ww,desc_data,info) ! If the original distribution has an overlap we should fix that. call psb_halo(x,desc_data,info,data=psb_comm_mov_) + if (do_alloc_wrk) call prec%free_wrk(info) if (present(work)) then else diff --git a/mlprec/impl/mld_smlprec_aply.f90 b/mlprec/impl/mld_smlprec_aply.f90 index 5a62c214..ebfcc34d 100644 --- a/mlprec/impl/mld_smlprec_aply.f90 +++ b/mlprec/impl/mld_smlprec_aply.f90 @@ -244,7 +244,7 @@ subroutine mld_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) trans_ = psb_toupper(trans) nlev = size(p%precv) - do_alloc_wrk = .not.allocated(p%wrk) + do_alloc_wrk = .not.allocated(p%precv(1)%wrk) if (do_alloc_wrk) call p%allocate_wrk(info,vmold=x%v) if (info /= psb_success_) then diff --git a/mlprec/impl/mld_sprecaply.f90 b/mlprec/impl/mld_sprecaply.f90 index e4065b7b..1dd1df22 100644 --- a/mlprec/impl/mld_sprecaply.f90 +++ b/mlprec/impl/mld_sprecaply.f90 @@ -360,7 +360,7 @@ subroutine mld_sprecaply2_vect(prec,x,y,desc_data,info,trans,work) goto 9999 end if - do_alloc_wrk = .not.allocated(prec%wrk) + do_alloc_wrk = .not.allocated(prec%precv(1)%wrk) if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) if (size(prec%precv) >1) then @@ -501,11 +501,11 @@ subroutine mld_sprecaply1_vect(prec,x,desc_data,info,trans,work) goto 9999 end if - do_alloc_wrk = .not.allocated(prec%wrk) + do_alloc_wrk = .not.allocated(prec%precv(1)%wrk) if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) associate(ww => prec%precv(1)%wrk%vtx, wv => prec%precv(1)%wrk%wv) - call psb_geasb(ww,desc_data,info,mold=x%v,scratch=.true.) + if (size(prec%precv) >1) then ! ! Number of levels > 1: apply the multilevel preconditioner @@ -561,11 +561,11 @@ subroutine mld_sprecaply1_vect(prec,x,desc_data,info,trans,work) goto 9999 endif end associate -!!$ if (info == 0) call psb_gefree(ww,desc_data,info) ! If the original distribution has an overlap we should fix that. call psb_halo(x,desc_data,info,data=psb_comm_mov_) + if (do_alloc_wrk) call prec%free_wrk(info) if (present(work)) then else diff --git a/mlprec/impl/mld_zmlprec_aply.f90 b/mlprec/impl/mld_zmlprec_aply.f90 index 920ba17f..a0d4f51e 100644 --- a/mlprec/impl/mld_zmlprec_aply.f90 +++ b/mlprec/impl/mld_zmlprec_aply.f90 @@ -244,7 +244,7 @@ subroutine mld_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) trans_ = psb_toupper(trans) nlev = size(p%precv) - do_alloc_wrk = .not.allocated(p%wrk) + do_alloc_wrk = .not.allocated(p%precv(1)%wrk) if (do_alloc_wrk) call p%allocate_wrk(info,vmold=x%v) if (info /= psb_success_) then diff --git a/mlprec/impl/mld_zprecaply.f90 b/mlprec/impl/mld_zprecaply.f90 index 2bb8a55c..d3db352e 100644 --- a/mlprec/impl/mld_zprecaply.f90 +++ b/mlprec/impl/mld_zprecaply.f90 @@ -360,7 +360,7 @@ subroutine mld_zprecaply2_vect(prec,x,y,desc_data,info,trans,work) goto 9999 end if - do_alloc_wrk = .not.allocated(prec%wrk) + do_alloc_wrk = .not.allocated(prec%precv(1)%wrk) if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) if (size(prec%precv) >1) then @@ -501,11 +501,11 @@ subroutine mld_zprecaply1_vect(prec,x,desc_data,info,trans,work) goto 9999 end if - do_alloc_wrk = .not.allocated(prec%wrk) + do_alloc_wrk = .not.allocated(prec%precv(1)%wrk) if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) associate(ww => prec%precv(1)%wrk%vtx, wv => prec%precv(1)%wrk%wv) - call psb_geasb(ww,desc_data,info,mold=x%v,scratch=.true.) + if (size(prec%precv) >1) then ! ! Number of levels > 1: apply the multilevel preconditioner @@ -561,11 +561,11 @@ subroutine mld_zprecaply1_vect(prec,x,desc_data,info,trans,work) goto 9999 endif end associate -!!$ if (info == 0) call psb_gefree(ww,desc_data,info) ! If the original distribution has an overlap we should fix that. call psb_halo(x,desc_data,info,data=psb_comm_mov_) + if (do_alloc_wrk) call prec%free_wrk(info) if (present(work)) then else diff --git a/mlprec/mld_c_onelev_mod.f90 b/mlprec/mld_c_onelev_mod.f90 index 17c7cb1c..ca80d8e2 100644 --- a/mlprec/mld_c_onelev_mod.f90 +++ b/mlprec/mld_c_onelev_mod.f90 @@ -131,7 +131,9 @@ module mld_c_onelev_mod procedure, pass(wk) :: clone => c_wrk_clone procedure, pass(wk) :: move_alloc => c_wrk_move_alloc end type mld_cmlprec_wrk_type - + private :: c_wrk_alloc, c_wrk_free, & + & c_wrk_clone, c_wrk_move_alloc + type mld_c_onelev_type class(mld_c_base_smoother_type), allocatable :: sm, sm2a class(mld_c_base_smoother_type), pointer :: sm2 => null() @@ -607,8 +609,10 @@ contains integer(psb_ipk_) :: nwv,i info = psb_success_ - call lv%wrk%free(info) - if (info == 0) deallocate(lv%wrk,stat=info) + if (allocated(lv%wrk)) then + call lv%wrk%free(info) + if (info == 0) deallocate(lv%wrk,stat=info) + end if end subroutine c_base_onelev_free_wrk subroutine c_wrk_alloc(wk,nwv,desc,info,vmold) diff --git a/mlprec/mld_c_prec_type.f90 b/mlprec/mld_c_prec_type.f90 index 1873d6ac..bc8b9425 100644 --- a/mlprec/mld_c_prec_type.f90 +++ b/mlprec/mld_c_prec_type.f90 @@ -109,7 +109,6 @@ module mld_c_prec_type ! The multilevel hierarchy ! type(mld_c_onelev_type), allocatable :: precv(:) - type(mld_cmlprec_wrk_type), allocatable :: wrk(:) contains procedure, pass(prec) :: psb_c_apply2_vect => mld_c_apply2_vect procedure, pass(prec) :: psb_c_apply1_vect => mld_c_apply1_vect @@ -782,8 +781,8 @@ contains end if end do end if - if (allocated(prec%wrk)) & - & call pout%allocate_wrk(info,vmold=prec%wrk(1)%vx2l%v) + if (allocated(prec%precv(1)%wrk)) & + & call pout%allocate_wrk(info,vmold=prec%precv(1)%wrk%vx2l%v) class default write(0,*) 'Error: wrong out type' @@ -818,7 +817,6 @@ contains b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc end do - call move_alloc(prec%wrk,b%wrk) else write(0,*) 'Warning: PREC%move_alloc onto different type?' @@ -844,32 +842,9 @@ contains name = 'mld_c_allocate_wrk' call psb_erractionsave(err_act) nlev = size(prec%precv) - allocate(prec%wrk(nlev),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if level = 1 do level = 1, nlev call prec%precv(level)%allocate_wrk(info,vmold=vmold) -!!$ call psb_geasb(prec%wrk(level)%vx2l,& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ call psb_geasb(prec%wrk(level)%vy2l,& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ call psb_geasb(prec%wrk(level)%vtx,& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ call psb_geasb(prec%wrk(level)%vty,& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ allocate(prec%wrk(level)%wv(wv_size_),stat=info) -!!$ do j=1, wv_size_ -!!$ call psb_geasb(prec%wrk(level)%wv(j),& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ end do if (psb_errstatus_fatal()) then nc2l = prec%precv(level)%base_desc%get_local_cols() info=psb_err_alloc_request_ @@ -906,38 +881,10 @@ contains name = 'mld_c_free_wrk' call psb_erractionsave(err_act) - if (allocated(prec%wrk)) then - nlev = size(prec%wrk) - - do level = 1, nlev - call prec%precv(level)%free_wrk(info) - !write(0,*) 'Free at level ',level,': x2,y2,tx,ty' -!!$ call prec%wrk(level)%vx2l%free(info) -!!$ call prec%wrk(level)%vy2l%free(info) -!!$ call prec%wrk(level)%vtx%free(info) -!!$ call prec%wrk(level)%vty%free(info) -!!$ !write(0,*) 'Free at level ',level,': vw[123]' -!!$ do j=1,wv_size_ -!!$ call prec%wrk(level)%wv(j)%free(info) -!!$ end do - !write(0,*) 'Free at level ',level,': done' - if (psb_errstatus_fatal()) then - info=psb_err_alloc_request_ - nc2l = prec%precv(level)%base_desc%get_local_cols() - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='complex(psb_spk_)') - goto 9999 - end if - end do - deallocate(prec%wrk,stat=info) - if (info /= 0) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/nlev,izero,izero,izero,izero/),& - & a_err='mld_cmlprec_wrk') - goto 9999 - end if - - end if + nlev = size(prec%precv) + do level = 1, nlev + call prec%precv(level)%free_wrk(info) + end do call psb_erractionrestore(err_act) return diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index 39d76100..bd693548 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -131,7 +131,9 @@ module mld_d_onelev_mod procedure, pass(wk) :: clone => d_wrk_clone procedure, pass(wk) :: move_alloc => d_wrk_move_alloc end type mld_dmlprec_wrk_type - + private :: d_wrk_alloc, d_wrk_free, & + & d_wrk_clone, d_wrk_move_alloc + type mld_d_onelev_type class(mld_d_base_smoother_type), allocatable :: sm, sm2a class(mld_d_base_smoother_type), pointer :: sm2 => null() @@ -607,8 +609,10 @@ contains integer(psb_ipk_) :: nwv,i info = psb_success_ - call lv%wrk%free(info) - if (info == 0) deallocate(lv%wrk,stat=info) + if (allocated(lv%wrk)) then + call lv%wrk%free(info) + if (info == 0) deallocate(lv%wrk,stat=info) + end if end subroutine d_base_onelev_free_wrk subroutine d_wrk_alloc(wk,nwv,desc,info,vmold) diff --git a/mlprec/mld_d_prec_type.f90 b/mlprec/mld_d_prec_type.f90 index 551cedab..1dd4b732 100644 --- a/mlprec/mld_d_prec_type.f90 +++ b/mlprec/mld_d_prec_type.f90 @@ -109,7 +109,6 @@ module mld_d_prec_type ! The multilevel hierarchy ! type(mld_d_onelev_type), allocatable :: precv(:) - type(mld_dmlprec_wrk_type), allocatable :: wrk(:) contains procedure, pass(prec) :: psb_d_apply2_vect => mld_d_apply2_vect procedure, pass(prec) :: psb_d_apply1_vect => mld_d_apply1_vect @@ -782,8 +781,8 @@ contains end if end do end if - if (allocated(prec%wrk)) & - & call pout%allocate_wrk(info,vmold=prec%wrk(1)%vx2l%v) + if (allocated(prec%precv(1)%wrk)) & + & call pout%allocate_wrk(info,vmold=prec%precv(1)%wrk%vx2l%v) class default write(0,*) 'Error: wrong out type' @@ -818,7 +817,6 @@ contains b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc end do - call move_alloc(prec%wrk,b%wrk) else write(0,*) 'Warning: PREC%move_alloc onto different type?' @@ -844,32 +842,9 @@ contains name = 'mld_d_allocate_wrk' call psb_erractionsave(err_act) nlev = size(prec%precv) - allocate(prec%wrk(nlev),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if level = 1 do level = 1, nlev call prec%precv(level)%allocate_wrk(info,vmold=vmold) -!!$ call psb_geasb(prec%wrk(level)%vx2l,& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ call psb_geasb(prec%wrk(level)%vy2l,& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ call psb_geasb(prec%wrk(level)%vtx,& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ call psb_geasb(prec%wrk(level)%vty,& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ allocate(prec%wrk(level)%wv(wv_size_),stat=info) -!!$ do j=1, wv_size_ -!!$ call psb_geasb(prec%wrk(level)%wv(j),& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ end do if (psb_errstatus_fatal()) then nc2l = prec%precv(level)%base_desc%get_local_cols() info=psb_err_alloc_request_ @@ -906,38 +881,10 @@ contains name = 'mld_d_free_wrk' call psb_erractionsave(err_act) - if (allocated(prec%wrk)) then - nlev = size(prec%wrk) - - do level = 1, nlev - call prec%precv(level)%free_wrk(info) - !write(0,*) 'Free at level ',level,': x2,y2,tx,ty' -!!$ call prec%wrk(level)%vx2l%free(info) -!!$ call prec%wrk(level)%vy2l%free(info) -!!$ call prec%wrk(level)%vtx%free(info) -!!$ call prec%wrk(level)%vty%free(info) -!!$ !write(0,*) 'Free at level ',level,': vw[123]' -!!$ do j=1,wv_size_ -!!$ call prec%wrk(level)%wv(j)%free(info) -!!$ end do - !write(0,*) 'Free at level ',level,': done' - if (psb_errstatus_fatal()) then - info=psb_err_alloc_request_ - nc2l = prec%precv(level)%base_desc%get_local_cols() - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='real(psb_dpk_)') - goto 9999 - end if - end do - deallocate(prec%wrk,stat=info) - if (info /= 0) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/nlev,izero,izero,izero,izero/),& - & a_err='mld_dmlprec_wrk') - goto 9999 - end if - - end if + nlev = size(prec%precv) + do level = 1, nlev + call prec%precv(level)%free_wrk(info) + end do call psb_erractionrestore(err_act) return diff --git a/mlprec/mld_s_onelev_mod.f90 b/mlprec/mld_s_onelev_mod.f90 index 39a98aa9..7a582b6b 100644 --- a/mlprec/mld_s_onelev_mod.f90 +++ b/mlprec/mld_s_onelev_mod.f90 @@ -131,7 +131,9 @@ module mld_s_onelev_mod procedure, pass(wk) :: clone => s_wrk_clone procedure, pass(wk) :: move_alloc => s_wrk_move_alloc end type mld_smlprec_wrk_type - + private :: s_wrk_alloc, s_wrk_free, & + & s_wrk_clone, s_wrk_move_alloc + type mld_s_onelev_type class(mld_s_base_smoother_type), allocatable :: sm, sm2a class(mld_s_base_smoother_type), pointer :: sm2 => null() @@ -607,8 +609,10 @@ contains integer(psb_ipk_) :: nwv,i info = psb_success_ - call lv%wrk%free(info) - if (info == 0) deallocate(lv%wrk,stat=info) + if (allocated(lv%wrk)) then + call lv%wrk%free(info) + if (info == 0) deallocate(lv%wrk,stat=info) + end if end subroutine s_base_onelev_free_wrk subroutine s_wrk_alloc(wk,nwv,desc,info,vmold) diff --git a/mlprec/mld_s_prec_type.f90 b/mlprec/mld_s_prec_type.f90 index 579b0e0b..21eae271 100644 --- a/mlprec/mld_s_prec_type.f90 +++ b/mlprec/mld_s_prec_type.f90 @@ -109,7 +109,6 @@ module mld_s_prec_type ! The multilevel hierarchy ! type(mld_s_onelev_type), allocatable :: precv(:) - type(mld_smlprec_wrk_type), allocatable :: wrk(:) contains procedure, pass(prec) :: psb_s_apply2_vect => mld_s_apply2_vect procedure, pass(prec) :: psb_s_apply1_vect => mld_s_apply1_vect @@ -782,8 +781,8 @@ contains end if end do end if - if (allocated(prec%wrk)) & - & call pout%allocate_wrk(info,vmold=prec%wrk(1)%vx2l%v) + if (allocated(prec%precv(1)%wrk)) & + & call pout%allocate_wrk(info,vmold=prec%precv(1)%wrk%vx2l%v) class default write(0,*) 'Error: wrong out type' @@ -818,7 +817,6 @@ contains b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc end do - call move_alloc(prec%wrk,b%wrk) else write(0,*) 'Warning: PREC%move_alloc onto different type?' @@ -844,32 +842,9 @@ contains name = 'mld_s_allocate_wrk' call psb_erractionsave(err_act) nlev = size(prec%precv) - allocate(prec%wrk(nlev),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if level = 1 do level = 1, nlev call prec%precv(level)%allocate_wrk(info,vmold=vmold) -!!$ call psb_geasb(prec%wrk(level)%vx2l,& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ call psb_geasb(prec%wrk(level)%vy2l,& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ call psb_geasb(prec%wrk(level)%vtx,& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ call psb_geasb(prec%wrk(level)%vty,& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ allocate(prec%wrk(level)%wv(wv_size_),stat=info) -!!$ do j=1, wv_size_ -!!$ call psb_geasb(prec%wrk(level)%wv(j),& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ end do if (psb_errstatus_fatal()) then nc2l = prec%precv(level)%base_desc%get_local_cols() info=psb_err_alloc_request_ @@ -906,38 +881,10 @@ contains name = 'mld_s_free_wrk' call psb_erractionsave(err_act) - if (allocated(prec%wrk)) then - nlev = size(prec%wrk) - - do level = 1, nlev - call prec%precv(level)%free_wrk(info) - !write(0,*) 'Free at level ',level,': x2,y2,tx,ty' -!!$ call prec%wrk(level)%vx2l%free(info) -!!$ call prec%wrk(level)%vy2l%free(info) -!!$ call prec%wrk(level)%vtx%free(info) -!!$ call prec%wrk(level)%vty%free(info) -!!$ !write(0,*) 'Free at level ',level,': vw[123]' -!!$ do j=1,wv_size_ -!!$ call prec%wrk(level)%wv(j)%free(info) -!!$ end do - !write(0,*) 'Free at level ',level,': done' - if (psb_errstatus_fatal()) then - info=psb_err_alloc_request_ - nc2l = prec%precv(level)%base_desc%get_local_cols() - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='real(psb_spk_)') - goto 9999 - end if - end do - deallocate(prec%wrk,stat=info) - if (info /= 0) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/nlev,izero,izero,izero,izero/),& - & a_err='mld_smlprec_wrk') - goto 9999 - end if - - end if + nlev = size(prec%precv) + do level = 1, nlev + call prec%precv(level)%free_wrk(info) + end do call psb_erractionrestore(err_act) return diff --git a/mlprec/mld_z_onelev_mod.f90 b/mlprec/mld_z_onelev_mod.f90 index e9f7cc71..589750bb 100644 --- a/mlprec/mld_z_onelev_mod.f90 +++ b/mlprec/mld_z_onelev_mod.f90 @@ -131,7 +131,9 @@ module mld_z_onelev_mod procedure, pass(wk) :: clone => z_wrk_clone procedure, pass(wk) :: move_alloc => z_wrk_move_alloc end type mld_zmlprec_wrk_type - + private :: z_wrk_alloc, z_wrk_free, & + & z_wrk_clone, z_wrk_move_alloc + type mld_z_onelev_type class(mld_z_base_smoother_type), allocatable :: sm, sm2a class(mld_z_base_smoother_type), pointer :: sm2 => null() @@ -607,8 +609,10 @@ contains integer(psb_ipk_) :: nwv,i info = psb_success_ - call lv%wrk%free(info) - if (info == 0) deallocate(lv%wrk,stat=info) + if (allocated(lv%wrk)) then + call lv%wrk%free(info) + if (info == 0) deallocate(lv%wrk,stat=info) + end if end subroutine z_base_onelev_free_wrk subroutine z_wrk_alloc(wk,nwv,desc,info,vmold) diff --git a/mlprec/mld_z_prec_type.f90 b/mlprec/mld_z_prec_type.f90 index 0c261a0a..ce8b4177 100644 --- a/mlprec/mld_z_prec_type.f90 +++ b/mlprec/mld_z_prec_type.f90 @@ -109,7 +109,6 @@ module mld_z_prec_type ! The multilevel hierarchy ! type(mld_z_onelev_type), allocatable :: precv(:) - type(mld_zmlprec_wrk_type), allocatable :: wrk(:) contains procedure, pass(prec) :: psb_z_apply2_vect => mld_z_apply2_vect procedure, pass(prec) :: psb_z_apply1_vect => mld_z_apply1_vect @@ -782,8 +781,8 @@ contains end if end do end if - if (allocated(prec%wrk)) & - & call pout%allocate_wrk(info,vmold=prec%wrk(1)%vx2l%v) + if (allocated(prec%precv(1)%wrk)) & + & call pout%allocate_wrk(info,vmold=prec%precv(1)%wrk%vx2l%v) class default write(0,*) 'Error: wrong out type' @@ -818,7 +817,6 @@ contains b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc end do - call move_alloc(prec%wrk,b%wrk) else write(0,*) 'Warning: PREC%move_alloc onto different type?' @@ -844,32 +842,9 @@ contains name = 'mld_z_allocate_wrk' call psb_erractionsave(err_act) nlev = size(prec%precv) - allocate(prec%wrk(nlev),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if level = 1 do level = 1, nlev call prec%precv(level)%allocate_wrk(info,vmold=vmold) -!!$ call psb_geasb(prec%wrk(level)%vx2l,& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ call psb_geasb(prec%wrk(level)%vy2l,& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ call psb_geasb(prec%wrk(level)%vtx,& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ call psb_geasb(prec%wrk(level)%vty,& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ allocate(prec%wrk(level)%wv(wv_size_),stat=info) -!!$ do j=1, wv_size_ -!!$ call psb_geasb(prec%wrk(level)%wv(j),& -!!$ & prec%precv(level)%base_desc,info,& -!!$ & scratch=.true.,mold=vmold) -!!$ end do if (psb_errstatus_fatal()) then nc2l = prec%precv(level)%base_desc%get_local_cols() info=psb_err_alloc_request_ @@ -906,38 +881,10 @@ contains name = 'mld_z_free_wrk' call psb_erractionsave(err_act) - if (allocated(prec%wrk)) then - nlev = size(prec%wrk) - - do level = 1, nlev - call prec%precv(level)%free_wrk(info) - !write(0,*) 'Free at level ',level,': x2,y2,tx,ty' -!!$ call prec%wrk(level)%vx2l%free(info) -!!$ call prec%wrk(level)%vy2l%free(info) -!!$ call prec%wrk(level)%vtx%free(info) -!!$ call prec%wrk(level)%vty%free(info) -!!$ !write(0,*) 'Free at level ',level,': vw[123]' -!!$ do j=1,wv_size_ -!!$ call prec%wrk(level)%wv(j)%free(info) -!!$ end do - !write(0,*) 'Free at level ',level,': done' - if (psb_errstatus_fatal()) then - info=psb_err_alloc_request_ - nc2l = prec%precv(level)%base_desc%get_local_cols() - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='complex(psb_dpk_)') - goto 9999 - end if - end do - deallocate(prec%wrk,stat=info) - if (info /= 0) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/nlev,izero,izero,izero,izero/),& - & a_err='mld_zmlprec_wrk') - goto 9999 - end if - - end if + nlev = size(prec%precv) + do level = 1, nlev + call prec%precv(level)%free_wrk(info) + end do call psb_erractionrestore(err_act) return