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

Taken out WRK(:) component of PREC, now we have the WRK component of LEV.

Browse Source
stopcriterion
Salvatore Filippone 7 years ago
parent 554f21992f
commit 3250853810
16 changed files with 72 additions and 268 deletions
Show Stats Download Patch File Download Diff File

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

@ -244,7 +244,7 @@ subroutine mld_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
trans_ = psb_toupper(trans) trans_ = psb_toupper(trans)
nlev = size(p%precv) 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 (do_alloc_wrk) call p%allocate_wrk(info,vmold=x%v)
if (info /= psb_success_) then if (info /= psb_success_) then

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

@ -360,7 +360,7 @@ subroutine mld_cprecaply2_vect(prec,x,y,desc_data,info,trans,work)
goto 9999 goto 9999
end if 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 (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
if (size(prec%precv) >1) then if (size(prec%precv) >1) then
@ -501,11 +501,11 @@ subroutine mld_cprecaply1_vect(prec,x,desc_data,info,trans,work)
goto 9999 goto 9999
end if 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 (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
associate(ww => prec%precv(1)%wrk%vtx, wv => prec%precv(1)%wrk%wv) 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 if (size(prec%precv) >1) then
! !
! Number of levels > 1: apply the multilevel preconditioner ! 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 goto 9999
endif endif
end associate end associate
!!$ if (info == 0) call psb_gefree(ww,desc_data,info)
! If the original distribution has an overlap we should fix that. ! If the original distribution has an overlap we should fix that.
call psb_halo(x,desc_data,info,data=psb_comm_mov_) call psb_halo(x,desc_data,info,data=psb_comm_mov_)
if (do_alloc_wrk) call prec%free_wrk(info)
if (present(work)) then if (present(work)) then
else else

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

@ -244,7 +244,7 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
trans_ = psb_toupper(trans) trans_ = psb_toupper(trans)
nlev = size(p%precv) 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 (do_alloc_wrk) call p%allocate_wrk(info,vmold=x%v)
if (info /= psb_success_) then if (info /= psb_success_) then

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

@ -360,7 +360,7 @@ subroutine mld_dprecaply2_vect(prec,x,y,desc_data,info,trans,work)
goto 9999 goto 9999
end if 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 (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
if (size(prec%precv) >1) then if (size(prec%precv) >1) then
@ -501,11 +501,11 @@ subroutine mld_dprecaply1_vect(prec,x,desc_data,info,trans,work)
goto 9999 goto 9999
end if 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 (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
associate(ww => prec%precv(1)%wrk%vtx, wv => prec%precv(1)%wrk%wv) 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 if (size(prec%precv) >1) then
! !
! Number of levels > 1: apply the multilevel preconditioner ! 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 goto 9999
endif endif
end associate end associate
!!$ if (info == 0) call psb_gefree(ww,desc_data,info)
! If the original distribution has an overlap we should fix that. ! If the original distribution has an overlap we should fix that.
call psb_halo(x,desc_data,info,data=psb_comm_mov_) call psb_halo(x,desc_data,info,data=psb_comm_mov_)
if (do_alloc_wrk) call prec%free_wrk(info)
if (present(work)) then if (present(work)) then
else else

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

@ -244,7 +244,7 @@ subroutine mld_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
trans_ = psb_toupper(trans) trans_ = psb_toupper(trans)
nlev = size(p%precv) 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 (do_alloc_wrk) call p%allocate_wrk(info,vmold=x%v)
if (info /= psb_success_) then if (info /= psb_success_) then

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

@ -360,7 +360,7 @@ subroutine mld_sprecaply2_vect(prec,x,y,desc_data,info,trans,work)
goto 9999 goto 9999
end if 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 (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
if (size(prec%precv) >1) then if (size(prec%precv) >1) then
@ -501,11 +501,11 @@ subroutine mld_sprecaply1_vect(prec,x,desc_data,info,trans,work)
goto 9999 goto 9999
end if 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 (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
associate(ww => prec%precv(1)%wrk%vtx, wv => prec%precv(1)%wrk%wv) 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 if (size(prec%precv) >1) then
! !
! Number of levels > 1: apply the multilevel preconditioner ! 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 goto 9999
endif endif
end associate end associate
!!$ if (info == 0) call psb_gefree(ww,desc_data,info)
! If the original distribution has an overlap we should fix that. ! If the original distribution has an overlap we should fix that.
call psb_halo(x,desc_data,info,data=psb_comm_mov_) call psb_halo(x,desc_data,info,data=psb_comm_mov_)
if (do_alloc_wrk) call prec%free_wrk(info)
if (present(work)) then if (present(work)) then
else else

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

@ -244,7 +244,7 @@ subroutine mld_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
trans_ = psb_toupper(trans) trans_ = psb_toupper(trans)
nlev = size(p%precv) 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 (do_alloc_wrk) call p%allocate_wrk(info,vmold=x%v)
if (info /= psb_success_) then if (info /= psb_success_) then

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

@ -360,7 +360,7 @@ subroutine mld_zprecaply2_vect(prec,x,y,desc_data,info,trans,work)
goto 9999 goto 9999
end if 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 (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
if (size(prec%precv) >1) then if (size(prec%precv) >1) then
@ -501,11 +501,11 @@ subroutine mld_zprecaply1_vect(prec,x,desc_data,info,trans,work)
goto 9999 goto 9999
end if 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 (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v)
associate(ww => prec%precv(1)%wrk%vtx, wv => prec%precv(1)%wrk%wv) 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 if (size(prec%precv) >1) then
! !
! Number of levels > 1: apply the multilevel preconditioner ! 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 goto 9999
endif endif
end associate end associate
!!$ if (info == 0) call psb_gefree(ww,desc_data,info)
! If the original distribution has an overlap we should fix that. ! If the original distribution has an overlap we should fix that.
call psb_halo(x,desc_data,info,data=psb_comm_mov_) call psb_halo(x,desc_data,info,data=psb_comm_mov_)
if (do_alloc_wrk) call prec%free_wrk(info)
if (present(work)) then if (present(work)) then
else else

8
mlprec/mld_c_onelev_mod.f90
Unescape Escape View File

@ -131,6 +131,8 @@ module mld_c_onelev_mod
procedure, pass(wk) :: clone => c_wrk_clone procedure, pass(wk) :: clone => c_wrk_clone
procedure, pass(wk) :: move_alloc => c_wrk_move_alloc procedure, pass(wk) :: move_alloc => c_wrk_move_alloc
end type mld_cmlprec_wrk_type 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 type mld_c_onelev_type
class(mld_c_base_smoother_type), allocatable :: sm, sm2a class(mld_c_base_smoother_type), allocatable :: sm, sm2a
@ -607,8 +609,10 @@ contains
integer(psb_ipk_) :: nwv,i integer(psb_ipk_) :: nwv,i
info = psb_success_ info = psb_success_
call lv%wrk%free(info) if (allocated(lv%wrk)) then
if (info == 0) deallocate(lv%wrk,stat=info) call lv%wrk%free(info)
if (info == 0) deallocate(lv%wrk,stat=info)
end if
end subroutine c_base_onelev_free_wrk end subroutine c_base_onelev_free_wrk
subroutine c_wrk_alloc(wk,nwv,desc,info,vmold) subroutine c_wrk_alloc(wk,nwv,desc,info,vmold)

65
mlprec/mld_c_prec_type.f90
Unescape Escape View File

@ -109,7 +109,6 @@ module mld_c_prec_type
! The multilevel hierarchy ! The multilevel hierarchy
! !
type(mld_c_onelev_type), allocatable :: precv(:) type(mld_c_onelev_type), allocatable :: precv(:)
type(mld_cmlprec_wrk_type), allocatable :: wrk(:)
contains contains
procedure, pass(prec) :: psb_c_apply2_vect => mld_c_apply2_vect procedure, pass(prec) :: psb_c_apply2_vect => mld_c_apply2_vect
procedure, pass(prec) :: psb_c_apply1_vect => mld_c_apply1_vect procedure, pass(prec) :: psb_c_apply1_vect => mld_c_apply1_vect
@ -782,8 +781,8 @@ contains
end if end if
end do end do
end if end if
if (allocated(prec%wrk)) & if (allocated(prec%precv(1)%wrk)) &
& call pout%allocate_wrk(info,vmold=prec%wrk(1)%vx2l%v) & call pout%allocate_wrk(info,vmold=prec%precv(1)%wrk%vx2l%v)
class default class default
write(0,*) 'Error: wrong out type' 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_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do end do
call move_alloc(prec%wrk,b%wrk)
else else
write(0,*) 'Warning: PREC%move_alloc onto different type?' write(0,*) 'Warning: PREC%move_alloc onto different type?'
@ -844,32 +842,9 @@ contains
name = 'mld_c_allocate_wrk' name = 'mld_c_allocate_wrk'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
nlev = size(prec%precv) 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 level = 1
do level = 1, nlev do level = 1, nlev
call prec%precv(level)%allocate_wrk(info,vmold=vmold) 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 if (psb_errstatus_fatal()) then
nc2l = prec%precv(level)%base_desc%get_local_cols() nc2l = prec%precv(level)%base_desc%get_local_cols()
info=psb_err_alloc_request_ info=psb_err_alloc_request_
@ -906,38 +881,10 @@ contains
name = 'mld_c_free_wrk' name = 'mld_c_free_wrk'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (allocated(prec%wrk)) then nlev = size(prec%precv)
nlev = size(prec%wrk) do level = 1, nlev
call prec%precv(level)%free_wrk(info)
do level = 1, nlev end do
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
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

8
mlprec/mld_d_onelev_mod.f90
Unescape Escape View File

@ -131,6 +131,8 @@ module mld_d_onelev_mod
procedure, pass(wk) :: clone => d_wrk_clone procedure, pass(wk) :: clone => d_wrk_clone
procedure, pass(wk) :: move_alloc => d_wrk_move_alloc procedure, pass(wk) :: move_alloc => d_wrk_move_alloc
end type mld_dmlprec_wrk_type 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 type mld_d_onelev_type
class(mld_d_base_smoother_type), allocatable :: sm, sm2a class(mld_d_base_smoother_type), allocatable :: sm, sm2a
@ -607,8 +609,10 @@ contains
integer(psb_ipk_) :: nwv,i integer(psb_ipk_) :: nwv,i
info = psb_success_ info = psb_success_
call lv%wrk%free(info) if (allocated(lv%wrk)) then
if (info == 0) deallocate(lv%wrk,stat=info) call lv%wrk%free(info)
if (info == 0) deallocate(lv%wrk,stat=info)
end if
end subroutine d_base_onelev_free_wrk end subroutine d_base_onelev_free_wrk
subroutine d_wrk_alloc(wk,nwv,desc,info,vmold) subroutine d_wrk_alloc(wk,nwv,desc,info,vmold)

65
mlprec/mld_d_prec_type.f90
Unescape Escape View File

@ -109,7 +109,6 @@ module mld_d_prec_type
! The multilevel hierarchy ! The multilevel hierarchy
! !
type(mld_d_onelev_type), allocatable :: precv(:) type(mld_d_onelev_type), allocatable :: precv(:)
type(mld_dmlprec_wrk_type), allocatable :: wrk(:)
contains contains
procedure, pass(prec) :: psb_d_apply2_vect => mld_d_apply2_vect procedure, pass(prec) :: psb_d_apply2_vect => mld_d_apply2_vect
procedure, pass(prec) :: psb_d_apply1_vect => mld_d_apply1_vect procedure, pass(prec) :: psb_d_apply1_vect => mld_d_apply1_vect
@ -782,8 +781,8 @@ contains
end if end if
end do end do
end if end if
if (allocated(prec%wrk)) & if (allocated(prec%precv(1)%wrk)) &
& call pout%allocate_wrk(info,vmold=prec%wrk(1)%vx2l%v) & call pout%allocate_wrk(info,vmold=prec%precv(1)%wrk%vx2l%v)
class default class default
write(0,*) 'Error: wrong out type' 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_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do end do
call move_alloc(prec%wrk,b%wrk)
else else
write(0,*) 'Warning: PREC%move_alloc onto different type?' write(0,*) 'Warning: PREC%move_alloc onto different type?'
@ -844,32 +842,9 @@ contains
name = 'mld_d_allocate_wrk' name = 'mld_d_allocate_wrk'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
nlev = size(prec%precv) 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 level = 1
do level = 1, nlev do level = 1, nlev
call prec%precv(level)%allocate_wrk(info,vmold=vmold) 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 if (psb_errstatus_fatal()) then
nc2l = prec%precv(level)%base_desc%get_local_cols() nc2l = prec%precv(level)%base_desc%get_local_cols()
info=psb_err_alloc_request_ info=psb_err_alloc_request_
@ -906,38 +881,10 @@ contains
name = 'mld_d_free_wrk' name = 'mld_d_free_wrk'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (allocated(prec%wrk)) then nlev = size(prec%precv)
nlev = size(prec%wrk) do level = 1, nlev
call prec%precv(level)%free_wrk(info)
do level = 1, nlev end do
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
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

8
mlprec/mld_s_onelev_mod.f90
Unescape Escape View File

@ -131,6 +131,8 @@ module mld_s_onelev_mod
procedure, pass(wk) :: clone => s_wrk_clone procedure, pass(wk) :: clone => s_wrk_clone
procedure, pass(wk) :: move_alloc => s_wrk_move_alloc procedure, pass(wk) :: move_alloc => s_wrk_move_alloc
end type mld_smlprec_wrk_type 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 type mld_s_onelev_type
class(mld_s_base_smoother_type), allocatable :: sm, sm2a class(mld_s_base_smoother_type), allocatable :: sm, sm2a
@ -607,8 +609,10 @@ contains
integer(psb_ipk_) :: nwv,i integer(psb_ipk_) :: nwv,i
info = psb_success_ info = psb_success_
call lv%wrk%free(info) if (allocated(lv%wrk)) then
if (info == 0) deallocate(lv%wrk,stat=info) call lv%wrk%free(info)
if (info == 0) deallocate(lv%wrk,stat=info)
end if
end subroutine s_base_onelev_free_wrk end subroutine s_base_onelev_free_wrk
subroutine s_wrk_alloc(wk,nwv,desc,info,vmold) subroutine s_wrk_alloc(wk,nwv,desc,info,vmold)

65
mlprec/mld_s_prec_type.f90
Unescape Escape View File

@ -109,7 +109,6 @@ module mld_s_prec_type
! The multilevel hierarchy ! The multilevel hierarchy
! !
type(mld_s_onelev_type), allocatable :: precv(:) type(mld_s_onelev_type), allocatable :: precv(:)
type(mld_smlprec_wrk_type), allocatable :: wrk(:)
contains contains
procedure, pass(prec) :: psb_s_apply2_vect => mld_s_apply2_vect procedure, pass(prec) :: psb_s_apply2_vect => mld_s_apply2_vect
procedure, pass(prec) :: psb_s_apply1_vect => mld_s_apply1_vect procedure, pass(prec) :: psb_s_apply1_vect => mld_s_apply1_vect
@ -782,8 +781,8 @@ contains
end if end if
end do end do
end if end if
if (allocated(prec%wrk)) & if (allocated(prec%precv(1)%wrk)) &
& call pout%allocate_wrk(info,vmold=prec%wrk(1)%vx2l%v) & call pout%allocate_wrk(info,vmold=prec%precv(1)%wrk%vx2l%v)
class default class default
write(0,*) 'Error: wrong out type' 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_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do end do
call move_alloc(prec%wrk,b%wrk)
else else
write(0,*) 'Warning: PREC%move_alloc onto different type?' write(0,*) 'Warning: PREC%move_alloc onto different type?'
@ -844,32 +842,9 @@ contains
name = 'mld_s_allocate_wrk' name = 'mld_s_allocate_wrk'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
nlev = size(prec%precv) 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 level = 1
do level = 1, nlev do level = 1, nlev
call prec%precv(level)%allocate_wrk(info,vmold=vmold) 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 if (psb_errstatus_fatal()) then
nc2l = prec%precv(level)%base_desc%get_local_cols() nc2l = prec%precv(level)%base_desc%get_local_cols()
info=psb_err_alloc_request_ info=psb_err_alloc_request_
@ -906,38 +881,10 @@ contains
name = 'mld_s_free_wrk' name = 'mld_s_free_wrk'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (allocated(prec%wrk)) then nlev = size(prec%precv)
nlev = size(prec%wrk) do level = 1, nlev
call prec%precv(level)%free_wrk(info)
do level = 1, nlev end do
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
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

8
mlprec/mld_z_onelev_mod.f90
Unescape Escape View File

@ -131,6 +131,8 @@ module mld_z_onelev_mod
procedure, pass(wk) :: clone => z_wrk_clone procedure, pass(wk) :: clone => z_wrk_clone
procedure, pass(wk) :: move_alloc => z_wrk_move_alloc procedure, pass(wk) :: move_alloc => z_wrk_move_alloc
end type mld_zmlprec_wrk_type 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 type mld_z_onelev_type
class(mld_z_base_smoother_type), allocatable :: sm, sm2a class(mld_z_base_smoother_type), allocatable :: sm, sm2a
@ -607,8 +609,10 @@ contains
integer(psb_ipk_) :: nwv,i integer(psb_ipk_) :: nwv,i
info = psb_success_ info = psb_success_
call lv%wrk%free(info) if (allocated(lv%wrk)) then
if (info == 0) deallocate(lv%wrk,stat=info) call lv%wrk%free(info)
if (info == 0) deallocate(lv%wrk,stat=info)
end if
end subroutine z_base_onelev_free_wrk end subroutine z_base_onelev_free_wrk
subroutine z_wrk_alloc(wk,nwv,desc,info,vmold) subroutine z_wrk_alloc(wk,nwv,desc,info,vmold)

65
mlprec/mld_z_prec_type.f90
Unescape Escape View File

@ -109,7 +109,6 @@ module mld_z_prec_type
! The multilevel hierarchy ! The multilevel hierarchy
! !
type(mld_z_onelev_type), allocatable :: precv(:) type(mld_z_onelev_type), allocatable :: precv(:)
type(mld_zmlprec_wrk_type), allocatable :: wrk(:)
contains contains
procedure, pass(prec) :: psb_z_apply2_vect => mld_z_apply2_vect procedure, pass(prec) :: psb_z_apply2_vect => mld_z_apply2_vect
procedure, pass(prec) :: psb_z_apply1_vect => mld_z_apply1_vect procedure, pass(prec) :: psb_z_apply1_vect => mld_z_apply1_vect
@ -782,8 +781,8 @@ contains
end if end if
end do end do
end if end if
if (allocated(prec%wrk)) & if (allocated(prec%precv(1)%wrk)) &
& call pout%allocate_wrk(info,vmold=prec%wrk(1)%vx2l%v) & call pout%allocate_wrk(info,vmold=prec%precv(1)%wrk%vx2l%v)
class default class default
write(0,*) 'Error: wrong out type' 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_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do end do
call move_alloc(prec%wrk,b%wrk)
else else
write(0,*) 'Warning: PREC%move_alloc onto different type?' write(0,*) 'Warning: PREC%move_alloc onto different type?'
@ -844,32 +842,9 @@ contains
name = 'mld_z_allocate_wrk' name = 'mld_z_allocate_wrk'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
nlev = size(prec%precv) 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 level = 1
do level = 1, nlev do level = 1, nlev
call prec%precv(level)%allocate_wrk(info,vmold=vmold) 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 if (psb_errstatus_fatal()) then
nc2l = prec%precv(level)%base_desc%get_local_cols() nc2l = prec%precv(level)%base_desc%get_local_cols()
info=psb_err_alloc_request_ info=psb_err_alloc_request_
@ -906,38 +881,10 @@ contains
name = 'mld_z_free_wrk' name = 'mld_z_free_wrk'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (allocated(prec%wrk)) then nlev = size(prec%precv)
nlev = size(prec%wrk) do level = 1, nlev
call prec%precv(level)%free_wrk(info)
do level = 1, nlev end do
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
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

Write Preview
Loading…
Cancel
Save