From fe110b83cabbe40df7cd7d241d06765311524058 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 6 Dec 2017 09:09:03 +0000 Subject: [PATCH] First step in work area: define alloc/free methods. --- mlprec/mld_base_prec_type.F90 | 4 +- mlprec/mld_c_prec_type.f90 | 138 +++++++++++++++++++++++++++++++++- mlprec/mld_d_prec_type.f90 | 138 +++++++++++++++++++++++++++++++++- mlprec/mld_s_prec_type.f90 | 138 +++++++++++++++++++++++++++++++++- mlprec/mld_z_prec_type.f90 | 138 +++++++++++++++++++++++++++++++++- 5 files changed, 546 insertions(+), 10 deletions(-) diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index c5453a66..491e6de2 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -81,10 +81,10 @@ module mld_base_prec_type ! ! Version numbers ! - character(len=*), parameter :: mld_version_string_ = "2.1.0" + character(len=*), parameter :: mld_version_string_ = "2.1.1" integer(psb_ipk_), parameter :: mld_version_major_ = 2 integer(psb_ipk_), parameter :: mld_version_minor_ = 1 - integer(psb_ipk_), parameter :: mld_patchlevel_ = 0 + integer(psb_ipk_), parameter :: mld_patchlevel_ = 1 type mld_ml_parms integer(psb_ipk_) :: sweeps_pre, sweeps_post diff --git a/mlprec/mld_c_prec_type.f90 b/mlprec/mld_c_prec_type.f90 index f83c096a..83243309 100644 --- a/mlprec/mld_c_prec_type.f90 +++ b/mlprec/mld_c_prec_type.f90 @@ -81,6 +81,13 @@ module mld_c_prec_type ! ! + type mld_cmlprec_wrk_type + complex(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + type(psb_c_vect_type) :: vtx, vty, vx2l, vy2l + type(psb_c_vect_type), allocatable :: wv(:) + end type mld_cmlprec_wrk_type + integer, parameter, private :: wv_size_=4 + type, extends(psb_cprec_type) :: mld_cprec_type integer(psb_ipk_) :: ictxt ! @@ -108,6 +115,7 @@ 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 @@ -116,6 +124,8 @@ module mld_c_prec_type procedure, pass(prec) :: dump => mld_c_dump procedure, pass(prec) :: clone => mld_c_clone procedure, pass(prec) :: free => mld_c_prec_free + procedure, pass(prec) :: allocate_wrk => mld_c_allocate_wrk + procedure, pass(prec) :: free_wrk => mld_c_free_wrk procedure, pass(prec) :: get_complexity => mld_c_get_compl procedure, pass(prec) :: cmp_complexity => mld_c_cmp_compl procedure, pass(prec) :: get_nlevs => mld_c_get_nlevs @@ -552,7 +562,7 @@ contains call psb_erractionsave(err_act) me=-1 - + call prec%free_wrk(info) if (allocated(prec%precv)) then do i=1,size(prec%precv) call prec%precv(i)%free(info) @@ -778,6 +788,9 @@ contains end if end do end if + if (allocated(prec%wrk)) & + & call pout%allocate_wrk(info,vmold=prec%wrk(1)%vx2l%v) + class default write(0,*) 'Error: wrong out type' info = psb_err_invalid_input_ @@ -811,10 +824,131 @@ 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?' info = psb_err_internal_error_ end if end subroutine c_prec_move_alloc - + + subroutine mld_c_allocate_wrk(prec,info,vmold) + use psb_base_mod + implicit none + + ! Arguments + class(mld_cprec_type), intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_vect_type), intent(in), optional :: vmold + + ! Local variables + integer(psb_ipk_) :: me,err_act,i,j,level,nlev, nc2l + character(len=20) :: name + + if(psb_get_errstatus().ne.0) return + info=psb_success_ + 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 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_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine mld_c_allocate_wrk + + + + subroutine mld_c_free_wrk(prec,info) + use psb_base_mod + implicit none + + ! Arguments + class(mld_cprec_type), intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + + ! Local variables + integer(psb_ipk_) :: me,err_act,i,j,level, nlev, nc2l + character(len=20) :: name + + if(psb_get_errstatus().ne.0) return + info=psb_success_ + name = 'mld_c_free_wrk' + call psb_erractionsave(err_act) + + if (allocated(prec%wrk)) then + nlev = size(prec%wrk) + + do level = 1, nlev + !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) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine mld_c_free_wrk + end module mld_c_prec_type diff --git a/mlprec/mld_d_prec_type.f90 b/mlprec/mld_d_prec_type.f90 index b3419c30..64b74187 100644 --- a/mlprec/mld_d_prec_type.f90 +++ b/mlprec/mld_d_prec_type.f90 @@ -81,6 +81,13 @@ module mld_d_prec_type ! ! + type mld_dmlprec_wrk_type + real(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + type(psb_d_vect_type) :: vtx, vty, vx2l, vy2l + type(psb_d_vect_type), allocatable :: wv(:) + end type mld_dmlprec_wrk_type + integer, parameter, private :: wv_size_=4 + type, extends(psb_dprec_type) :: mld_dprec_type integer(psb_ipk_) :: ictxt ! @@ -108,6 +115,7 @@ 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 @@ -116,6 +124,8 @@ module mld_d_prec_type procedure, pass(prec) :: dump => mld_d_dump procedure, pass(prec) :: clone => mld_d_clone procedure, pass(prec) :: free => mld_d_prec_free + procedure, pass(prec) :: allocate_wrk => mld_d_allocate_wrk + procedure, pass(prec) :: free_wrk => mld_d_free_wrk procedure, pass(prec) :: get_complexity => mld_d_get_compl procedure, pass(prec) :: cmp_complexity => mld_d_cmp_compl procedure, pass(prec) :: get_nlevs => mld_d_get_nlevs @@ -552,7 +562,7 @@ contains call psb_erractionsave(err_act) me=-1 - + call prec%free_wrk(info) if (allocated(prec%precv)) then do i=1,size(prec%precv) call prec%precv(i)%free(info) @@ -778,6 +788,9 @@ contains end if end do end if + if (allocated(prec%wrk)) & + & call pout%allocate_wrk(info,vmold=prec%wrk(1)%vx2l%v) + class default write(0,*) 'Error: wrong out type' info = psb_err_invalid_input_ @@ -811,10 +824,131 @@ 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?' info = psb_err_internal_error_ end if end subroutine d_prec_move_alloc - + + subroutine mld_d_allocate_wrk(prec,info,vmold) + use psb_base_mod + implicit none + + ! Arguments + class(mld_dprec_type), intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_vect_type), intent(in), optional :: vmold + + ! Local variables + integer(psb_ipk_) :: me,err_act,i,j,level,nlev, nc2l + character(len=20) :: name + + if(psb_get_errstatus().ne.0) return + info=psb_success_ + 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 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_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine mld_d_allocate_wrk + + + + subroutine mld_d_free_wrk(prec,info) + use psb_base_mod + implicit none + + ! Arguments + class(mld_dprec_type), intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + + ! Local variables + integer(psb_ipk_) :: me,err_act,i,j,level, nlev, nc2l + character(len=20) :: name + + if(psb_get_errstatus().ne.0) return + info=psb_success_ + name = 'mld_d_free_wrk' + call psb_erractionsave(err_act) + + if (allocated(prec%wrk)) then + nlev = size(prec%wrk) + + do level = 1, nlev + !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) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine mld_d_free_wrk + end module mld_d_prec_type diff --git a/mlprec/mld_s_prec_type.f90 b/mlprec/mld_s_prec_type.f90 index b3d74b94..1cfd35c7 100644 --- a/mlprec/mld_s_prec_type.f90 +++ b/mlprec/mld_s_prec_type.f90 @@ -81,6 +81,13 @@ module mld_s_prec_type ! ! + type mld_smlprec_wrk_type + real(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + type(psb_s_vect_type) :: vtx, vty, vx2l, vy2l + type(psb_s_vect_type), allocatable :: wv(:) + end type mld_smlprec_wrk_type + integer, parameter, private :: wv_size_=4 + type, extends(psb_sprec_type) :: mld_sprec_type integer(psb_ipk_) :: ictxt ! @@ -108,6 +115,7 @@ 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 @@ -116,6 +124,8 @@ module mld_s_prec_type procedure, pass(prec) :: dump => mld_s_dump procedure, pass(prec) :: clone => mld_s_clone procedure, pass(prec) :: free => mld_s_prec_free + procedure, pass(prec) :: allocate_wrk => mld_s_allocate_wrk + procedure, pass(prec) :: free_wrk => mld_s_free_wrk procedure, pass(prec) :: get_complexity => mld_s_get_compl procedure, pass(prec) :: cmp_complexity => mld_s_cmp_compl procedure, pass(prec) :: get_nlevs => mld_s_get_nlevs @@ -552,7 +562,7 @@ contains call psb_erractionsave(err_act) me=-1 - + call prec%free_wrk(info) if (allocated(prec%precv)) then do i=1,size(prec%precv) call prec%precv(i)%free(info) @@ -778,6 +788,9 @@ contains end if end do end if + if (allocated(prec%wrk)) & + & call pout%allocate_wrk(info,vmold=prec%wrk(1)%vx2l%v) + class default write(0,*) 'Error: wrong out type' info = psb_err_invalid_input_ @@ -811,10 +824,131 @@ 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?' info = psb_err_internal_error_ end if end subroutine s_prec_move_alloc - + + subroutine mld_s_allocate_wrk(prec,info,vmold) + use psb_base_mod + implicit none + + ! Arguments + class(mld_sprec_type), intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_vect_type), intent(in), optional :: vmold + + ! Local variables + integer(psb_ipk_) :: me,err_act,i,j,level,nlev, nc2l + character(len=20) :: name + + if(psb_get_errstatus().ne.0) return + info=psb_success_ + 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 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_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine mld_s_allocate_wrk + + + + subroutine mld_s_free_wrk(prec,info) + use psb_base_mod + implicit none + + ! Arguments + class(mld_sprec_type), intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + + ! Local variables + integer(psb_ipk_) :: me,err_act,i,j,level, nlev, nc2l + character(len=20) :: name + + if(psb_get_errstatus().ne.0) return + info=psb_success_ + name = 'mld_s_free_wrk' + call psb_erractionsave(err_act) + + if (allocated(prec%wrk)) then + nlev = size(prec%wrk) + + do level = 1, nlev + !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) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine mld_s_free_wrk + end module mld_s_prec_type diff --git a/mlprec/mld_z_prec_type.f90 b/mlprec/mld_z_prec_type.f90 index df130c6f..aa06cf25 100644 --- a/mlprec/mld_z_prec_type.f90 +++ b/mlprec/mld_z_prec_type.f90 @@ -81,6 +81,13 @@ module mld_z_prec_type ! ! + type mld_zmlprec_wrk_type + complex(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + type(psb_z_vect_type) :: vtx, vty, vx2l, vy2l + type(psb_z_vect_type), allocatable :: wv(:) + end type mld_zmlprec_wrk_type + integer, parameter, private :: wv_size_=4 + type, extends(psb_zprec_type) :: mld_zprec_type integer(psb_ipk_) :: ictxt ! @@ -108,6 +115,7 @@ 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 @@ -116,6 +124,8 @@ module mld_z_prec_type procedure, pass(prec) :: dump => mld_z_dump procedure, pass(prec) :: clone => mld_z_clone procedure, pass(prec) :: free => mld_z_prec_free + procedure, pass(prec) :: allocate_wrk => mld_z_allocate_wrk + procedure, pass(prec) :: free_wrk => mld_z_free_wrk procedure, pass(prec) :: get_complexity => mld_z_get_compl procedure, pass(prec) :: cmp_complexity => mld_z_cmp_compl procedure, pass(prec) :: get_nlevs => mld_z_get_nlevs @@ -552,7 +562,7 @@ contains call psb_erractionsave(err_act) me=-1 - + call prec%free_wrk(info) if (allocated(prec%precv)) then do i=1,size(prec%precv) call prec%precv(i)%free(info) @@ -778,6 +788,9 @@ contains end if end do end if + if (allocated(prec%wrk)) & + & call pout%allocate_wrk(info,vmold=prec%wrk(1)%vx2l%v) + class default write(0,*) 'Error: wrong out type' info = psb_err_invalid_input_ @@ -811,10 +824,131 @@ 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?' info = psb_err_internal_error_ end if end subroutine z_prec_move_alloc - + + subroutine mld_z_allocate_wrk(prec,info,vmold) + use psb_base_mod + implicit none + + ! Arguments + class(mld_zprec_type), intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_vect_type), intent(in), optional :: vmold + + ! Local variables + integer(psb_ipk_) :: me,err_act,i,j,level,nlev, nc2l + character(len=20) :: name + + if(psb_get_errstatus().ne.0) return + info=psb_success_ + 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 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_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine mld_z_allocate_wrk + + + + subroutine mld_z_free_wrk(prec,info) + use psb_base_mod + implicit none + + ! Arguments + class(mld_zprec_type), intent(inout) :: prec + integer(psb_ipk_), intent(out) :: info + + ! Local variables + integer(psb_ipk_) :: me,err_act,i,j,level, nlev, nc2l + character(len=20) :: name + + if(psb_get_errstatus().ne.0) return + info=psb_success_ + name = 'mld_z_free_wrk' + call psb_erractionsave(err_act) + + if (allocated(prec%wrk)) then + nlev = size(prec%wrk) + + do level = 1, nlev + !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) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine mld_z_free_wrk + end module mld_z_prec_type