From fe110b83cabbe40df7cd7d241d06765311524058 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 6 Dec 2017 09:09:03 +0000 Subject: [PATCH 01/16] 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 From 55ec0f3da0612efad60b4ad43619cd8106cbeac3 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 6 Dec 2017 09:27:39 +0000 Subject: [PATCH 02/16] Added WV to smoother method --- mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 | 3 ++- mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 | 5 +++-- mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 | 5 +++-- mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 | 3 ++- mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 | 5 +++-- mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 | 5 +++-- mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 | 3 ++- mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 | 5 +++-- mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 | 5 +++-- mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 | 3 ++- mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 | 5 +++-- mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 | 5 +++-- mlprec/mld_c_as_smoother.f90 | 3 ++- mlprec/mld_c_base_smoother_mod.f90 | 3 ++- mlprec/mld_c_jac_smoother.f90 | 3 ++- mlprec/mld_d_as_smoother.f90 | 3 ++- mlprec/mld_d_base_smoother_mod.f90 | 3 ++- mlprec/mld_d_jac_smoother.f90 | 3 ++- mlprec/mld_s_as_smoother.f90 | 3 ++- mlprec/mld_s_base_smoother_mod.f90 | 3 ++- mlprec/mld_s_jac_smoother.f90 | 3 ++- mlprec/mld_z_as_smoother.f90 | 3 ++- mlprec/mld_z_base_smoother_mod.f90 | 3 ++- mlprec/mld_z_jac_smoother.f90 | 3 ++- tests/pdegen/mld_d_pde2d.f90 | 2 +- tests/pdegen/mld_d_pde3d.f90 | 2 +- tests/pdegen/mld_s_pde2d.f90 | 2 +- tests/pdegen/mld_s_pde3d.f90 | 2 +- 28 files changed, 60 insertions(+), 36 deletions(-) diff --git a/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 index 1f442af4..fa3d666a 100644 --- a/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu) + & sweeps,work,info,init,initu,wv) use psb_base_mod use mld_c_as_smoother, mld_protect_nam => mld_c_as_smoother_apply_vect implicit none @@ -51,6 +51,7 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu + type(psb_c_vect_type),intent(inout), optional :: wv(:) integer(psb_ipk_) :: n_row,n_col, nrow_d, i complex(psb_spk_), pointer :: aux(:) diff --git a/mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 index d27d9d8b..cc7eb484 100644 --- a/mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu) + & trans,sweeps,work,info,init,initu,wv) use psb_base_mod use mld_c_base_smoother_mod, mld_protect_name => mld_c_base_smoother_apply_vect implicit none @@ -51,7 +51,8 @@ subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu - + type(psb_c_vect_type),intent(inout), optional :: wv(:) + ! integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_smoother_apply' diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 index 057a651a..ce9d45f7 100644 --- a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu) + & sweeps,work,info,init,initu,wv) use psb_base_mod use mld_c_jac_smoother, mld_protect_name => mld_c_jac_smoother_apply_vect @@ -52,7 +52,8 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu - + type(psb_c_vect_type),intent(inout), optional :: wv(:) + ! integer(psb_ipk_) :: n_row,n_col type(psb_c_vect_type) :: tx, ty complex(psb_spk_), pointer :: aux(:) diff --git a/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 index 2c8114a7..08784800 100644 --- a/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu) + & sweeps,work,info,init,initu,wv) use psb_base_mod use mld_d_as_smoother, mld_protect_nam => mld_d_as_smoother_apply_vect implicit none @@ -51,6 +51,7 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu + type(psb_d_vect_type),intent(inout), optional :: wv(:) integer(psb_ipk_) :: n_row,n_col, nrow_d, i real(psb_dpk_), pointer :: aux(:) diff --git a/mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 index 6982c80a..2033b7a0 100644 --- a/mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu) + & trans,sweeps,work,info,init,initu,wv) use psb_base_mod use mld_d_base_smoother_mod, mld_protect_name => mld_d_base_smoother_apply_vect implicit none @@ -51,7 +51,8 @@ subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu - + type(psb_d_vect_type),intent(inout), optional :: wv(:) + ! integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_smoother_apply' diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 index de352727..280bc233 100644 --- a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu) + & sweeps,work,info,init,initu,wv) use psb_base_mod use mld_d_jac_smoother, mld_protect_name => mld_d_jac_smoother_apply_vect @@ -52,7 +52,8 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu - + type(psb_d_vect_type),intent(inout), optional :: wv(:) + ! integer(psb_ipk_) :: n_row,n_col type(psb_d_vect_type) :: tx, ty real(psb_dpk_), pointer :: aux(:) diff --git a/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 index 9b89d844..1e12bff5 100644 --- a/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu) + & sweeps,work,info,init,initu,wv) use psb_base_mod use mld_s_as_smoother, mld_protect_nam => mld_s_as_smoother_apply_vect implicit none @@ -51,6 +51,7 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu + type(psb_s_vect_type),intent(inout), optional :: wv(:) integer(psb_ipk_) :: n_row,n_col, nrow_d, i real(psb_spk_), pointer :: aux(:) diff --git a/mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 index ee296f9c..031b52e4 100644 --- a/mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu) + & trans,sweeps,work,info,init,initu,wv) use psb_base_mod use mld_s_base_smoother_mod, mld_protect_name => mld_s_base_smoother_apply_vect implicit none @@ -51,7 +51,8 @@ subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu - + type(psb_s_vect_type),intent(inout), optional :: wv(:) + ! integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_smoother_apply' diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 index 7442e4e8..24f81fa7 100644 --- a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu) + & sweeps,work,info,init,initu,wv) use psb_base_mod use mld_s_jac_smoother, mld_protect_name => mld_s_jac_smoother_apply_vect @@ -52,7 +52,8 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu - + type(psb_s_vect_type),intent(inout), optional :: wv(:) + ! integer(psb_ipk_) :: n_row,n_col type(psb_s_vect_type) :: tx, ty real(psb_spk_), pointer :: aux(:) diff --git a/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 index bb3cce93..c0658c33 100644 --- a/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu) + & sweeps,work,info,init,initu,wv) use psb_base_mod use mld_z_as_smoother, mld_protect_nam => mld_z_as_smoother_apply_vect implicit none @@ -51,6 +51,7 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu + type(psb_z_vect_type),intent(inout), optional :: wv(:) integer(psb_ipk_) :: n_row,n_col, nrow_d, i complex(psb_dpk_), pointer :: aux(:) diff --git a/mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 index 448cfaaa..c8edb655 100644 --- a/mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu) + & trans,sweeps,work,info,init,initu,wv) use psb_base_mod use mld_z_base_smoother_mod, mld_protect_name => mld_z_base_smoother_apply_vect implicit none @@ -51,7 +51,8 @@ subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu - + type(psb_z_vect_type),intent(inout), optional :: wv(:) + ! integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_smoother_apply' diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 index ee97b9c9..0e61fbab 100644 --- a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu) + & sweeps,work,info,init,initu,wv) use psb_base_mod use mld_z_jac_smoother, mld_protect_name => mld_z_jac_smoother_apply_vect @@ -52,7 +52,8 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu - + type(psb_z_vect_type),intent(inout), optional :: wv(:) + ! integer(psb_ipk_) :: n_row,n_col type(psb_z_vect_type) :: tx, ty complex(psb_dpk_), pointer :: aux(:) diff --git a/mlprec/mld_c_as_smoother.f90 b/mlprec/mld_c_as_smoother.f90 index 3ff35bb5..8f19d162 100644 --- a/mlprec/mld_c_as_smoother.f90 +++ b/mlprec/mld_c_as_smoother.f90 @@ -179,7 +179,7 @@ module mld_c_as_smoother interface subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu) + & trans,sweeps,work,info,init,initu,wv) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_spk_, mld_c_as_smoother_type, psb_long_int_k_, & & psb_desc_type, psb_ipk_ @@ -195,6 +195,7 @@ module mld_c_as_smoother integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu + type(psb_c_vect_type),intent(inout), optional :: wv(:) end subroutine mld_c_as_smoother_apply_vect end interface diff --git a/mlprec/mld_c_base_smoother_mod.f90 b/mlprec/mld_c_base_smoother_mod.f90 index 8cab4558..c442d048 100644 --- a/mlprec/mld_c_base_smoother_mod.f90 +++ b/mlprec/mld_c_base_smoother_mod.f90 @@ -153,7 +153,7 @@ module mld_c_base_smoother_mod interface subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu) + & trans,sweeps,work,info,init,initu,wv) import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & & mld_c_base_smoother_type, psb_ipk_ @@ -168,6 +168,7 @@ module mld_c_base_smoother_mod integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu + type(psb_c_vect_type),intent(inout), optional :: wv(:) end subroutine mld_c_base_smoother_apply_vect end interface diff --git a/mlprec/mld_c_jac_smoother.f90 b/mlprec/mld_c_jac_smoother.f90 index bd6e744d..50bf6f19 100644 --- a/mlprec/mld_c_jac_smoother.f90 +++ b/mlprec/mld_c_jac_smoother.f90 @@ -83,7 +83,7 @@ module mld_c_jac_smoother interface subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu) + & sweeps,work,info,init,initu,wv) import :: psb_desc_type, mld_c_jac_smoother_type, psb_c_vect_type, psb_spk_, & & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type,& & psb_ipk_ @@ -99,6 +99,7 @@ module mld_c_jac_smoother integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu + type(psb_c_vect_type),intent(inout), optional :: wv(:) end subroutine mld_c_jac_smoother_apply_vect end interface diff --git a/mlprec/mld_d_as_smoother.f90 b/mlprec/mld_d_as_smoother.f90 index 6ea82acf..2f5b6633 100644 --- a/mlprec/mld_d_as_smoother.f90 +++ b/mlprec/mld_d_as_smoother.f90 @@ -179,7 +179,7 @@ module mld_d_as_smoother interface subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu) + & trans,sweeps,work,info,init,initu,wv) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dpk_, mld_d_as_smoother_type, psb_long_int_k_, & & psb_desc_type, psb_ipk_ @@ -195,6 +195,7 @@ module mld_d_as_smoother integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu + type(psb_d_vect_type),intent(inout), optional :: wv(:) end subroutine mld_d_as_smoother_apply_vect end interface diff --git a/mlprec/mld_d_base_smoother_mod.f90 b/mlprec/mld_d_base_smoother_mod.f90 index 7af4a5eb..36742af5 100644 --- a/mlprec/mld_d_base_smoother_mod.f90 +++ b/mlprec/mld_d_base_smoother_mod.f90 @@ -153,7 +153,7 @@ module mld_d_base_smoother_mod interface subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu) + & trans,sweeps,work,info,init,initu,wv) import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & & mld_d_base_smoother_type, psb_ipk_ @@ -168,6 +168,7 @@ module mld_d_base_smoother_mod integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu + type(psb_d_vect_type),intent(inout), optional :: wv(:) end subroutine mld_d_base_smoother_apply_vect end interface diff --git a/mlprec/mld_d_jac_smoother.f90 b/mlprec/mld_d_jac_smoother.f90 index ff36d868..db3010b8 100644 --- a/mlprec/mld_d_jac_smoother.f90 +++ b/mlprec/mld_d_jac_smoother.f90 @@ -83,7 +83,7 @@ module mld_d_jac_smoother interface subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu) + & sweeps,work,info,init,initu,wv) import :: psb_desc_type, mld_d_jac_smoother_type, psb_d_vect_type, psb_dpk_, & & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,& & psb_ipk_ @@ -99,6 +99,7 @@ module mld_d_jac_smoother integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu + type(psb_d_vect_type),intent(inout), optional :: wv(:) end subroutine mld_d_jac_smoother_apply_vect end interface diff --git a/mlprec/mld_s_as_smoother.f90 b/mlprec/mld_s_as_smoother.f90 index 196fbfce..437af7d0 100644 --- a/mlprec/mld_s_as_smoother.f90 +++ b/mlprec/mld_s_as_smoother.f90 @@ -179,7 +179,7 @@ module mld_s_as_smoother interface subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu) + & trans,sweeps,work,info,init,initu,wv) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_spk_, mld_s_as_smoother_type, psb_long_int_k_, & & psb_desc_type, psb_ipk_ @@ -195,6 +195,7 @@ module mld_s_as_smoother integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu + type(psb_s_vect_type),intent(inout), optional :: wv(:) end subroutine mld_s_as_smoother_apply_vect end interface diff --git a/mlprec/mld_s_base_smoother_mod.f90 b/mlprec/mld_s_base_smoother_mod.f90 index 6af05762..b8aa11e8 100644 --- a/mlprec/mld_s_base_smoother_mod.f90 +++ b/mlprec/mld_s_base_smoother_mod.f90 @@ -153,7 +153,7 @@ module mld_s_base_smoother_mod interface subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu) + & trans,sweeps,work,info,init,initu,wv) import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & & mld_s_base_smoother_type, psb_ipk_ @@ -168,6 +168,7 @@ module mld_s_base_smoother_mod integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu + type(psb_s_vect_type),intent(inout), optional :: wv(:) end subroutine mld_s_base_smoother_apply_vect end interface diff --git a/mlprec/mld_s_jac_smoother.f90 b/mlprec/mld_s_jac_smoother.f90 index d688ca8d..ff8704bd 100644 --- a/mlprec/mld_s_jac_smoother.f90 +++ b/mlprec/mld_s_jac_smoother.f90 @@ -83,7 +83,7 @@ module mld_s_jac_smoother interface subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu) + & sweeps,work,info,init,initu,wv) import :: psb_desc_type, mld_s_jac_smoother_type, psb_s_vect_type, psb_spk_, & & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,& & psb_ipk_ @@ -99,6 +99,7 @@ module mld_s_jac_smoother integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu + type(psb_s_vect_type),intent(inout), optional :: wv(:) end subroutine mld_s_jac_smoother_apply_vect end interface diff --git a/mlprec/mld_z_as_smoother.f90 b/mlprec/mld_z_as_smoother.f90 index b37a0173..a7fba9eb 100644 --- a/mlprec/mld_z_as_smoother.f90 +++ b/mlprec/mld_z_as_smoother.f90 @@ -179,7 +179,7 @@ module mld_z_as_smoother interface subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu) + & trans,sweeps,work,info,init,initu,wv) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_dpk_, mld_z_as_smoother_type, psb_long_int_k_, & & psb_desc_type, psb_ipk_ @@ -195,6 +195,7 @@ module mld_z_as_smoother integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu + type(psb_z_vect_type),intent(inout), optional :: wv(:) end subroutine mld_z_as_smoother_apply_vect end interface diff --git a/mlprec/mld_z_base_smoother_mod.f90 b/mlprec/mld_z_base_smoother_mod.f90 index 7312b9c0..98b01657 100644 --- a/mlprec/mld_z_base_smoother_mod.f90 +++ b/mlprec/mld_z_base_smoother_mod.f90 @@ -153,7 +153,7 @@ module mld_z_base_smoother_mod interface subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu) + & trans,sweeps,work,info,init,initu,wv) import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & & mld_z_base_smoother_type, psb_ipk_ @@ -168,6 +168,7 @@ module mld_z_base_smoother_mod integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu + type(psb_z_vect_type),intent(inout), optional :: wv(:) end subroutine mld_z_base_smoother_apply_vect end interface diff --git a/mlprec/mld_z_jac_smoother.f90 b/mlprec/mld_z_jac_smoother.f90 index f009a088..1e6146a7 100644 --- a/mlprec/mld_z_jac_smoother.f90 +++ b/mlprec/mld_z_jac_smoother.f90 @@ -83,7 +83,7 @@ module mld_z_jac_smoother interface subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu) + & sweeps,work,info,init,initu,wv) import :: psb_desc_type, mld_z_jac_smoother_type, psb_z_vect_type, psb_dpk_, & & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,& & psb_ipk_ @@ -99,6 +99,7 @@ module mld_z_jac_smoother integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu + type(psb_z_vect_type),intent(inout), optional :: wv(:) end subroutine mld_z_jac_smoother_apply_vect end interface diff --git a/tests/pdegen/mld_d_pde2d.f90 b/tests/pdegen/mld_d_pde2d.f90 index 4b011f0c..9b31e101 100644 --- a/tests/pdegen/mld_d_pde2d.f90 +++ b/tests/pdegen/mld_d_pde2d.f90 @@ -730,8 +730,8 @@ program mld_d_pde2d call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) - call prec%descr(info) if (iam == psb_root_) then + call prec%descr(info) write(psb_out_unit,'("Computed solution on ",i8," processors")') np write(psb_out_unit,'("Krylov method : ",a)') trim(s_choice%kmethd) write(psb_out_unit,'("Preconditioner : ",a)') trim(p_choice%descr) diff --git a/tests/pdegen/mld_d_pde3d.f90 b/tests/pdegen/mld_d_pde3d.f90 index 4fef2189..ba87fc99 100644 --- a/tests/pdegen/mld_d_pde3d.f90 +++ b/tests/pdegen/mld_d_pde3d.f90 @@ -784,8 +784,8 @@ program mld_d_pde3d call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) - call prec%descr(info) if (iam == psb_root_) then + call prec%descr(info) write(psb_out_unit,'("Computed solution on ",i8," processors")') np write(psb_out_unit,'("Krylov method : ",a)') trim(s_choice%kmethd) write(psb_out_unit,'("Preconditioner : ",a)') trim(p_choice%descr) diff --git a/tests/pdegen/mld_s_pde2d.f90 b/tests/pdegen/mld_s_pde2d.f90 index 57af569f..2c590f22 100644 --- a/tests/pdegen/mld_s_pde2d.f90 +++ b/tests/pdegen/mld_s_pde2d.f90 @@ -730,8 +730,8 @@ program mld_s_pde2d call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) - call prec%descr(info) if (iam == psb_root_) then + call prec%descr(info) write(psb_out_unit,'("Computed solution on ",i8," processors")') np write(psb_out_unit,'("Krylov method : ",a)') trim(s_choice%kmethd) write(psb_out_unit,'("Preconditioner : ",a)') trim(p_choice%descr) diff --git a/tests/pdegen/mld_s_pde3d.f90 b/tests/pdegen/mld_s_pde3d.f90 index 19ff5e86..b454ed25 100644 --- a/tests/pdegen/mld_s_pde3d.f90 +++ b/tests/pdegen/mld_s_pde3d.f90 @@ -784,8 +784,8 @@ program mld_s_pde3d call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) - call prec%descr(info) if (iam == psb_root_) then + call prec%descr(info) write(psb_out_unit,'("Computed solution on ",i8," processors")') np write(psb_out_unit,'("Krylov method : ",a)') trim(s_choice%kmethd) write(psb_out_unit,'("Preconditioner : ",a)') trim(p_choice%descr) From f1f3240f27e595b577bc17d055c6723f2f8c55d7 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 6 Dec 2017 09:34:36 +0000 Subject: [PATCH 03/16] Fixed prec%descr call --- tests/fileread/mld_cf_sample.f90 | 2 +- tests/fileread/mld_df_sample.f90 | 2 +- tests/fileread/mld_sf_sample.f90 | 2 +- tests/fileread/mld_zf_sample.f90 | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/fileread/mld_cf_sample.f90 b/tests/fileread/mld_cf_sample.f90 index 904d6494..cee3631d 100644 --- a/tests/fileread/mld_cf_sample.f90 +++ b/tests/fileread/mld_cf_sample.f90 @@ -516,8 +516,8 @@ program mld_cf_sample call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) - call prec%descr(info) if (iam == psb_root_) then + call prec%descr(info) write(psb_out_unit,'("Matrix: ",a)')mtrx_file write(psb_out_unit,'("Computed solution on ",i8," processors")')np write(psb_out_unit,'("Krylov method : ",a)') trim(s_choice%kmethd) diff --git a/tests/fileread/mld_df_sample.f90 b/tests/fileread/mld_df_sample.f90 index 1779726a..dee9bfc8 100644 --- a/tests/fileread/mld_df_sample.f90 +++ b/tests/fileread/mld_df_sample.f90 @@ -516,8 +516,8 @@ program mld_df_sample call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) - call prec%descr(info) if (iam == psb_root_) then + call prec%descr(info) write(psb_out_unit,'("Matrix: ",a)')mtrx_file write(psb_out_unit,'("Computed solution on ",i8," processors")')np write(psb_out_unit,'("Krylov method : ",a)') trim(s_choice%kmethd) diff --git a/tests/fileread/mld_sf_sample.f90 b/tests/fileread/mld_sf_sample.f90 index 8e6ec8db..df5c1f28 100644 --- a/tests/fileread/mld_sf_sample.f90 +++ b/tests/fileread/mld_sf_sample.f90 @@ -516,8 +516,8 @@ program mld_sf_sample call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) - call prec%descr(info) if (iam == psb_root_) then + call prec%descr(info) write(psb_out_unit,'("Matrix: ",a)')mtrx_file write(psb_out_unit,'("Computed solution on ",i8," processors")')np write(psb_out_unit,'("Krylov method : ",a)') trim(s_choice%kmethd) diff --git a/tests/fileread/mld_zf_sample.f90 b/tests/fileread/mld_zf_sample.f90 index b89052ab..91716f87 100644 --- a/tests/fileread/mld_zf_sample.f90 +++ b/tests/fileread/mld_zf_sample.f90 @@ -516,8 +516,8 @@ program mld_zf_sample call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) - call prec%descr(info) if (iam == psb_root_) then + call prec%descr(info) write(psb_out_unit,'("Matrix: ",a)')mtrx_file write(psb_out_unit,'("Computed solution on ",i8," processors")')np write(psb_out_unit,'("Krylov method : ",a)') trim(s_choice%kmethd) From 5e174d062e80d4514307df70f262dde7627a9d63 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 6 Dec 2017 16:11:53 +0000 Subject: [PATCH 04/16] Update mlprec_aply to use WRK. --- mlprec/impl/mld_cmlprec_aply.f90 | 341 ++++++++++++++----------------- mlprec/impl/mld_dmlprec_aply.f90 | 341 ++++++++++++++----------------- mlprec/impl/mld_smlprec_aply.f90 | 341 ++++++++++++++----------------- mlprec/impl/mld_zmlprec_aply.f90 | 341 ++++++++++++++----------------- mlprec/mld_c_inner_mod.f90 | 3 +- mlprec/mld_d_inner_mod.f90 | 3 +- mlprec/mld_s_inner_mod.f90 | 3 +- mlprec/mld_z_inner_mod.f90 | 3 +- 8 files changed, 608 insertions(+), 768 deletions(-) diff --git a/mlprec/impl/mld_cmlprec_aply.f90 b/mlprec/impl/mld_cmlprec_aply.f90 index fdc41cda..4378f3d6 100644 --- a/mlprec/impl/mld_cmlprec_aply.f90 +++ b/mlprec/impl/mld_cmlprec_aply.f90 @@ -225,11 +225,8 @@ subroutine mld_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) character(len=20) :: name character :: trans_ complex(psb_spk_) :: beta_ - type mld_mlprec_wrk_type - complex(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) - type(psb_c_vect_type) :: vtx, vty, vx2l, vy2l - end type mld_mlprec_wrk_type - type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) + logical :: do_alloc_wrk + type(mld_cmlprec_wrk_type), allocatable, target :: mlprec_wrk(:) name='mld_cmlprec_aply' info = psb_success_ @@ -245,34 +242,15 @@ subroutine mld_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) & ' Entry ', size(p%precv) trans_ = psb_toupper(trans) - nlev = size(p%precv) - allocate(mlprec_wrk(nlev),stat=info) + nlev = size(p%precv) + + do_alloc_wrk = .not.allocated(p%wrk) + + if (do_alloc_wrk) call p%allocate_wrk(info,vmold=x%v) 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(mlprec_wrk(level)%vx2l,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vtx,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vty,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - if (psb_errstatus_fatal()) then - nc2l = p%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 ! ! At first iteration we must use the input BETA ! @@ -280,31 +258,35 @@ subroutine mld_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) level = 1 - call psb_geaxpby(cone,x,czero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) + call psb_geaxpby(cone,x,czero,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='geaxbpy') + goto 9999 + end if do isweep = 1, p%outer_sweeps - 1 ! ! With the current implementation, y2l is zeroed internally at first smoother. - ! call mlprec_wrk(level)%vy2l%zero() + ! call p%wrk(level)%vy2l%zero() ! - call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) + call inner_ml_aply(level,p,trans_,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Inner prec aply') goto 9999 end if - call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta_,y,& + call psb_geaxpby(alpha,p%wrk(level)%vy2l,beta_,y,& & p%precv(level)%base_desc,info) ! all iterations after the first must use BETA = 1 beta_ = cone ! ! Next iteration should use the current residual to compute a correction ! - call psb_geaxpby(cone,x,czero,mlprec_wrk(level)%vx2l,& + call psb_geaxpby(cone,x,czero,p%wrk(level)%vx2l,& & p%precv(level)%base_desc,info) call psb_spmm(-cone,p%precv(level)%base_a,y,& - & cone,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) + & cone,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) end do ! @@ -314,40 +296,24 @@ subroutine mld_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) ! ! With the current implementation, y2l is zeroed internally at first smoother. - ! call mlprec_wrk(level)%vy2l%zero() + ! call p%wrk(level)%vy2l%zero() ! - call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) + call inner_ml_aply(level,p,trans_,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Inner prec aply') goto 9999 end if - - call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta_,y,& + call psb_geaxpby(alpha,p%wrk(level)%vy2l,beta_,y,& & p%precv(level)%base_desc,info) - - do level = 1, nlev - - call mlprec_wrk(level)%vx2l%free(info) - call mlprec_wrk(level)%vy2l%free(info) - call mlprec_wrk(level)%vtx%free(info) - call mlprec_wrk(level)%vty%free(info) - if (psb_errstatus_fatal()) then - info=psb_err_alloc_request_ - nc2l = p%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 if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error final update') goto 9999 end if - + if (do_alloc_wrk) call p%free_wrk(info) call psb_erractionrestore(err_act) return @@ -379,14 +345,13 @@ contains ! between level and level+1 are stored at level+1. ! ! - recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info) + recursive subroutine inner_ml_aply(level,p,trans,work,info) implicit none ! Arguments integer(psb_ipk_) :: level type(mld_cprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) character, intent(in) :: trans complex(psb_spk_),target :: work(:) integer(psb_ipk_), intent(out) :: info @@ -419,7 +384,7 @@ contains call psb_info(ictxt, me, np) if(debug_level > 1) then - write(debug_unit,*) me,' Start inner_ml_aply at level ',level + write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info end if select case(p%precv(level)%parms%ml_cycle) @@ -434,15 +399,15 @@ contains case(mld_add_ml_) - call mld_c_inner_add(p, mlprec_wrk, level, trans, work) + call mld_c_inner_add(p, level, trans, work) case(mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_) - call mld_c_inner_mult(p, mlprec_wrk, level, trans, work) + call mld_c_inner_mult(p, level, trans, work) case(mld_kcycle_ml_, mld_kcyclesym_ml_) - call mld_c_inner_k_cycle(p, mlprec_wrk, level, trans, work) + call mld_c_inner_k_cycle(p, level, trans, work) case default info = psb_err_from_subroutine_ai_ @@ -464,7 +429,7 @@ contains end subroutine inner_ml_aply - recursive subroutine mld_c_inner_add(p, mlprec_wrk, level, trans, work) + recursive subroutine mld_c_inner_add(p, level, trans, work) use psb_base_mod use mld_prec_mod @@ -473,7 +438,6 @@ contains !Input/Oputput variables type(mld_cprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans complex(psb_spk_),target :: work(:) @@ -517,18 +481,18 @@ contains if (allocated(p%precv(level)%sm2a)) then call psb_geaxpby(cone,& - & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,czero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc,info) sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post) do k=1, sweeps call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%vy2l,czero,mlprec_wrk(level)%vtx,& + & p%wrk(level)%vy2l,czero,p%wrk(level)%vtx,& & p%precv(level)%base_desc, trans,& & ione,work,info,init='Z') call p%precv(level)%sm2a%apply(cone,& - & mlprec_wrk(level)%vtx,czero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vtx,czero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & ione,work,info,init='Z') end do @@ -536,7 +500,7 @@ contains else sweeps = p%precv(level)%parms%sweeps_pre call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,czero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -548,8 +512,8 @@ contains if (level < nlev) then ! Apply the restriction - call psb_map_X2Y(cone,mlprec_wrk(level)%vx2l,& - & czero,mlprec_wrk(level+1)%vx2l,& + call psb_map_X2Y(cone,p%wrk(level)%vx2l,& + & czero,p%wrk(level+1)%vx2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -557,7 +521,7 @@ contains goto 9999 end if - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,trans,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error in recursive call') @@ -567,8 +531,8 @@ contains ! ! Apply the prolongator ! - call psb_map_Y2X(cone,mlprec_wrk(level+1)%vy2l,& - & cone,mlprec_wrk(level)%vy2l,& + call psb_map_Y2X(cone,p%wrk(level+1)%vy2l,& + & cone,p%wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -587,7 +551,7 @@ contains end subroutine mld_c_inner_add - recursive subroutine mld_c_inner_mult(p, mlprec_wrk, level, trans, work) + recursive subroutine mld_c_inner_mult(p, level, trans, work) use psb_base_mod use mld_prec_mod @@ -596,7 +560,6 @@ contains !Input/Oputput variables type(mld_cprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans complex(psb_spk_),target :: work(:) @@ -633,7 +596,6 @@ contains sweeps_pre = p%precv(level)%parms%sweeps_pre pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) - if (level < nlev) then ! @@ -645,13 +607,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,czero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& - & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,czero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -662,25 +624,24 @@ contains goto 9999 end if endif - ! ! Compute the residual and call recursively ! if (pre) then - call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,& - & czero,mlprec_wrk(level)%vty,& + call psb_geaxpby(cone,p%wrk(level)%vx2l,& + & czero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,cone,mlprec_wrk(level)%vty,& + & p%wrk(level)%vy2l,cone,p%wrk(level)%vty,& & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') goto 9999 end if - call psb_map_X2Y(cone,mlprec_wrk(level)%vty,& - & czero,mlprec_wrk(level+1)%vx2l,& + call psb_map_X2Y(cone,p%wrk(level)%vty,& + & czero,p%wrk(level+1)%vx2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -689,8 +650,8 @@ contains end if else ! Shortcut: just transfer x2l. - call psb_map_X2Y(cone,mlprec_wrk(level)%vx2l,& - & czero,mlprec_wrk(level+1)%vx2l,& + call psb_map_X2Y(cone,p%wrk(level)%vx2l,& + & czero,p%wrk(level+1)%vx2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -699,13 +660,13 @@ contains end if endif - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,trans,work,info) ! ! Apply the prolongator ! - call psb_map_Y2X(cone,mlprec_wrk(level+1)%vy2l,& - & cone,mlprec_wrk(level)%vy2l,& + call psb_map_Y2X(cone,p%wrk(level+1)%vy2l,& + & cone,p%wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -715,14 +676,14 @@ contains if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then - call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,& - & czero,mlprec_wrk(level)%vty,& + call psb_geaxpby(cone,p%wrk(level)%vx2l,& + & czero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,cone,mlprec_wrk(level)%vty,& + & p%wrk(level)%vy2l,cone,p%wrk(level)%vty,& & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info == psb_success_) call psb_map_X2Y(cone,mlprec_wrk(level)%vty,& - & czero,mlprec_wrk(level+1)%vx2l,& + if (info == psb_success_) call psb_map_X2Y(cone,p%wrk(level)%vty,& + & czero,p%wrk(level+1)%vx2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -730,10 +691,10 @@ contains goto 9999 end if - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,trans,work,info) - if (info == psb_success_) call psb_map_Y2X(cone,mlprec_wrk(level+1)%vy2l,& - & cone,mlprec_wrk(level)%vy2l,& + if (info == psb_success_) call psb_map_Y2X(cone,p%wrk(level+1)%vy2l,& + & cone,p%wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then @@ -746,12 +707,12 @@ contains if (post) then - call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,& - & czero,mlprec_wrk(level)%vty,& + call psb_geaxpby(cone,p%wrk(level)%vx2l,& + & czero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,& - & cone,mlprec_wrk(level)%vty,p%precv(level)%base_desc,info,& + & p%wrk(level)%vy2l,& + & cone,p%wrk(level)%vty,p%precv(level)%base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -765,13 +726,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& - & mlprec_wrk(level)%vty,cone,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vty,cone,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%vty,cone,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vty,cone,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -788,7 +749,7 @@ contains sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,czero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -808,7 +769,7 @@ contains end subroutine mld_c_inner_mult - recursive subroutine mld_c_inner_k_cycle(p, mlprec_wrk, level, trans, work,u) + recursive subroutine mld_c_inner_k_cycle(p, level, trans, work,u) use psb_base_mod use mld_prec_mod @@ -816,7 +777,6 @@ contains !Input/Oputput variables type(mld_cprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans complex(psb_spk_),target :: work(:) @@ -870,7 +830,7 @@ contains ! sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,czero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') @@ -879,13 +839,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,czero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& - & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,czero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -901,12 +861,12 @@ contains ! Compute the residual and call recursively ! - call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,& - & czero,mlprec_wrk(level)%vty,& + call psb_geaxpby(cone,p%wrk(level)%vx2l,& + & czero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,cone,mlprec_wrk(level)%vty,& + & p%wrk(level)%vy2l,cone,p%wrk(level)%vty,& & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -915,8 +875,8 @@ contains end if ! Apply the restriction - call psb_map_X2Y(cone,mlprec_wrk(level)%vty,& - & czero,mlprec_wrk(level + 1)%vx2l,& + call psb_map_X2Y(cone,p%wrk(level)%vty,& + & czero,p%wrk(level + 1)%vx2l,& & p%precv(level + 1)%map,info,work=work) if (info /= psb_success_) then @@ -929,16 +889,16 @@ contains if (level <= nlev - 2 ) then if (p%precv(level)%parms%ml_cycle == mld_kcyclesym_ml_) then - call mld_cinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'FCG') + call mld_cinneritkcycle(p, level + 1, trans, work, 'FCG') elseif (p%precv(level)%parms%ml_cycle == mld_kcycle_ml_) then - call mld_cinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'GCR') + call mld_cinneritkcycle(p, level + 1, trans, work, 'GCR') else call psb_errpush(psb_err_internal_error_,name,& & a_err='Bad value for ml_cycle') goto 9999 endif else - call inner_ml_aply(level + 1 ,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level + 1 ,p,trans,work,info) endif if (info /= psb_success_) then @@ -950,8 +910,8 @@ contains ! ! Apply the prolongator ! - call psb_map_Y2X(cone,mlprec_wrk(level+1)%vy2l,& - & cone,mlprec_wrk(level)%vy2l,& + call psb_map_Y2X(cone,p%wrk(level+1)%vy2l,& + & cone,p%wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then @@ -963,11 +923,11 @@ contains ! ! Compute the residual ! - call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,& - & czero,mlprec_wrk(level)%vty,& + call psb_geaxpby(cone,p%wrk(level)%vx2l,& + & czero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) - call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - & cone,mlprec_wrk(level)%vty,p%precv(level)%base_desc,info,& + call psb_spmm(-cone,p%precv(level)%base_a,p%wrk(level)%vy2l,& + & cone,p%wrk(level)%vty,p%precv(level)%base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -980,13 +940,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& - & mlprec_wrk(level)%vty,cone,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vty,cone,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%vty,cone,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vty,cone,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -1014,7 +974,7 @@ contains end subroutine mld_c_inner_k_cycle - recursive subroutine mld_cinneritkcycle(p, mlprec_wrk, level, trans, work, innersolv) + recursive subroutine mld_cinneritkcycle(p, level, trans, work, innersolv) use psb_base_mod use mld_prec_mod use mld_c_inner_mod, mld_protect_name => mld_cmlprec_aply @@ -1024,7 +984,6 @@ contains !Input/Oputput variables type(mld_cprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans character(len=*), intent(in) :: innersolv @@ -1044,34 +1003,34 @@ contains call psb_geasb(rhs,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) call psb_geasb(w,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) call psb_geasb(v,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) call psb_geasb(v1,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) call psb_geasb(x,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) !Assemble d(0) and d(1) call psb_geasb(d(0),& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) + & scratch=.true.,mold=p%wrk(level)%vy2l%v) call psb_geasb(d(1),& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) + & scratch=.true.,mold=p%wrk(level)%vy2l%v) call x%zero() ! rhs=vx2l and w=rhs - call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,czero,rhs,& + call psb_geaxpby(cone,p%wrk(level)%vx2l,czero,rhs,& & p%precv(level)%base_desc,info) - call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,czero,w,& + call psb_geaxpby(cone,p%wrk(level)%vx2l,czero,w,& & p%precv(level)%base_desc,info) if (psb_errstatus_fatal()) then @@ -1085,12 +1044,12 @@ contains delta0 = psb_genrm2(w, p%precv(level)%base_desc, info) !Apply the preconditioner - call mlprec_wrk(level)%vy2l%zero() + call p%wrk(level)%vy2l%zero() idx=0 - call inner_ml_aply(level,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level,p,trans,work,info) - call psb_geaxpby(cone,mlprec_wrk(level)%vy2l,czero,d(idx),p%precv(level)%base_desc,info) + call psb_geaxpby(cone,p%wrk(level)%vy2l,czero,d(idx),p%precv(level)%base_desc,info) call psb_spmm(cone,p%precv(level)%base_a,d(idx),czero,v,p%precv(level)%base_desc,info) if (info /= psb_success_) then @@ -1128,9 +1087,9 @@ contains idx=mod(iter,2) !Apply preconditioner - call psb_geaxpby(cone,w,czero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) - call inner_ml_aply(level,p,mlprec_wrk,trans,work,info) - call psb_geaxpby(cone,mlprec_wrk(level)%vy2l,czero,d(idx),p%precv(level)%base_desc,info) + call psb_geaxpby(cone,w,czero,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) + call inner_ml_aply(level,p,trans,work,info) + call psb_geaxpby(cone,p%wrk(level)%vy2l,czero,d(idx),p%precv(level)%base_desc,info) !Sparse matrix vector product @@ -1165,7 +1124,7 @@ contains call psb_geaxpby(alpha,d(idx),cone,x,p%precv(level)%base_desc,info) endif - call psb_geaxpby(cone,x,czero,mlprec_wrk(level)%vy2l,p%precv(level)%base_desc,info) + call psb_geaxpby(cone,x,czero,p%wrk(level)%vy2l,p%precv(level)%base_desc,info) !Free vectors call psb_gefree(v, p%precv(level)%base_desc, info) call psb_gefree(v1, p%precv(level)%base_desc, info) @@ -1217,10 +1176,10 @@ subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level character(len=20) :: name character :: trans_ - type mld_mlprec_wrk_type + type mld_mlwrk_type complex(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) - end type mld_mlprec_wrk_type - type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) + end type mld_mlwrk_type + type(mld_mlwrk_type), allocatable, target :: mlwrk(:) name='mld_cmlprec_aply' info = psb_success_ @@ -1238,7 +1197,7 @@ subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) trans_ = psb_toupper(trans) nlev = size(p%precv) - allocate(mlprec_wrk(nlev),stat=info) + allocate(mlwrk(nlev),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 @@ -1246,13 +1205,13 @@ subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) level = 1 do level = 1, nlev - call psb_geasb(mlprec_wrk(level)%x2l,& + call psb_geasb(mlwrk(level)%x2l,& & p%precv(level)%base_desc,info) - call psb_geasb(mlprec_wrk(level)%y2l,& + call psb_geasb(mlwrk(level)%y2l,& & p%precv(level)%base_desc,info) - call psb_geasb(mlprec_wrk(level)%tx,& + call psb_geasb(mlwrk(level)%tx,& & p%precv(level)%base_desc,info) - call psb_geasb(mlprec_wrk(level)%ty,& + call psb_geasb(mlwrk(level)%ty,& & p%precv(level)%base_desc,info) if (psb_errstatus_fatal()) then nc2l = p%precv(level)%base_desc%get_local_cols() @@ -1263,10 +1222,10 @@ subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) end if end do - mlprec_wrk(level)%x2l(:) = x(:) - mlprec_wrk(level)%y2l(:) = czero + mlwrk(level)%x2l(:) = x(:) + mlwrk(level)%y2l(:) = czero - call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) + call inner_ml_aply(level,p,mlwrk,trans_,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1274,7 +1233,7 @@ subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) goto 9999 end if - call psb_geaxpby(alpha,mlprec_wrk(level)%y2l,beta,y,& + call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,& & p%precv(level)%base_desc,info) if (info /= psb_success_) then @@ -1315,14 +1274,14 @@ contains ! between level and level+1 are stored at level+1. ! ! - recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info) + recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info) implicit none ! Arguments integer(psb_ipk_) :: level type(mld_cprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) + type(mld_mlwrk_type), intent(inout), target :: mlwrk(:) character, intent(in) :: trans complex(psb_spk_),target :: work(:) integer(psb_ipk_), intent(out) :: info @@ -1370,15 +1329,15 @@ contains case(mld_add_ml_) - call mld_c_inner_add(p, mlprec_wrk, level, trans, work) + call mld_c_inner_add(p, mlwrk, level, trans, work) case(mld_mult_ml_, mld_vcycle_ml_, mld_wcycle_ml_) - call mld_c_inner_mult(p, mlprec_wrk, level, trans, work) + call mld_c_inner_mult(p, mlwrk, level, trans, work) ! !$ case(mld_kcycle_ml_, mld_kcyclesym_ml_) ! !$ -! !$ call mld_c_inner_k_cycle(p, mlprec_wrk, level, trans, work) +! !$ call mld_c_inner_k_cycle(p, mlwrk, level, trans, work) case default info = psb_err_from_subroutine_ai_ @@ -1397,7 +1356,7 @@ contains end subroutine inner_ml_aply - recursive subroutine mld_c_inner_add(p, mlprec_wrk, level, trans, work) + recursive subroutine mld_c_inner_add(p, mlwrk, level, trans, work) use psb_base_mod use mld_prec_mod @@ -1406,7 +1365,7 @@ contains !Input/Oputput variables type(mld_cprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + type(mld_mlwrk_type), target, intent(inout) :: mlwrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans complex(psb_spk_),target :: work(:) @@ -1450,7 +1409,7 @@ contains sweeps = p%precv(level)%parms%sweeps_pre call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& + & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then @@ -1461,17 +1420,17 @@ contains if (level < nlev) then ! Apply the restriction - call psb_map_X2Y(cone,mlprec_wrk(level)%x2l,& - & czero,mlprec_wrk(level+1)%x2l,& + call psb_map_X2Y(cone,mlwrk(level)%x2l,& + & czero,mlwrk(level+1)%x2l,& & p%precv(level+1)%map,info,work=work) - mlprec_wrk(level+1)%y2l(:) = czero + mlwrk(level+1)%y2l(:) = czero if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') goto 9999 end if - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,mlwrk,trans,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error in recursive call') @@ -1481,8 +1440,8 @@ contains ! ! Apply the prolongator and add correction. ! - call psb_map_Y2X(cone,mlprec_wrk(level+1)%y2l,& - & cone,mlprec_wrk(level)%y2l,& + call psb_map_Y2X(cone,mlwrk(level+1)%y2l,& + & cone,mlwrk(level)%y2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1501,7 +1460,7 @@ contains end subroutine mld_c_inner_add - recursive subroutine mld_c_inner_mult(p, mlprec_wrk, level, trans, work) + recursive subroutine mld_c_inner_mult(p, mlwrk, level, trans, work) use psb_base_mod use mld_prec_mod @@ -1510,7 +1469,7 @@ contains !Input/Oputput variables type(mld_cprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + type(mld_mlwrk_type), target, intent(inout) :: mlwrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans complex(psb_spk_),target :: work(:) @@ -1567,13 +1526,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& + & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Y') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& - & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& + & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Y') end if @@ -1589,20 +1548,20 @@ contains ! Compute the residual and call recursively ! if (pre) then - call psb_geaxpby(cone,mlprec_wrk(level)%x2l,& - & czero,mlprec_wrk(level)%ty,& + call psb_geaxpby(cone,mlwrk(level)%x2l,& + & czero,mlwrk(level)%ty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& - & mlprec_wrk(level)%y2l,cone,mlprec_wrk(level)%ty,& + & mlwrk(level)%y2l,cone,mlwrk(level)%ty,& & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') goto 9999 end if - call psb_map_X2Y(cone,mlprec_wrk(level)%ty,& - & czero,mlprec_wrk(level+1)%x2l,& + call psb_map_X2Y(cone,mlwrk(level)%ty,& + & czero,mlwrk(level+1)%x2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1611,8 +1570,8 @@ contains end if else ! Shortcut: just transfer x2l. - call psb_map_X2Y(cone,mlprec_wrk(level)%x2l,& - & czero,mlprec_wrk(level+1)%x2l,& + call psb_map_X2Y(cone,mlwrk(level)%x2l,& + & czero,mlwrk(level+1)%x2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1621,14 +1580,14 @@ contains end if endif ! First guess is zero - mlprec_wrk(level+1)%y2l(:) = czero + mlwrk(level+1)%y2l(:) = czero - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,mlwrk,trans,work,info) if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then ! On second call will use output y2l as initial guess - if (info == psb_success_) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info) endif if (info /= psb_success_) then @@ -1641,8 +1600,8 @@ contains ! ! Apply the prolongator ! - call psb_map_Y2X(cone,mlprec_wrk(level+1)%y2l,& - & cone,mlprec_wrk(level)%y2l,& + call psb_map_Y2X(cone,mlwrk(level+1)%y2l,& + & cone,mlwrk(level)%y2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1654,11 +1613,11 @@ contains ! Compute the residual ! if (post) then - call psb_geaxpby(cone,mlprec_wrk(level)%x2l,& - & czero,mlprec_wrk(level)%tx,& + call psb_geaxpby(cone,mlwrk(level)%x2l,& + & czero,mlwrk(level)%tx,& & p%precv(level)%base_desc,info) - call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& - & cone,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,& + call psb_spmm(-cone,p%precv(level)%base_a,mlwrk(level)%y2l,& + & cone,mlwrk(level)%tx,p%precv(level)%base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1671,13 +1630,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& - & mlprec_wrk(level)%tx,cone,mlprec_wrk(level)%y2l,& + & mlwrk(level)%tx,cone,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%tx,cone,mlprec_wrk(level)%y2l,& + & mlwrk(level)%tx,cone,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -1694,7 +1653,7 @@ contains sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& + & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) diff --git a/mlprec/impl/mld_dmlprec_aply.f90 b/mlprec/impl/mld_dmlprec_aply.f90 index 4397e793..3a0010cd 100644 --- a/mlprec/impl/mld_dmlprec_aply.f90 +++ b/mlprec/impl/mld_dmlprec_aply.f90 @@ -225,11 +225,8 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) character(len=20) :: name character :: trans_ real(psb_dpk_) :: beta_ - type mld_mlprec_wrk_type - real(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) - type(psb_d_vect_type) :: vtx, vty, vx2l, vy2l - end type mld_mlprec_wrk_type - type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) + logical :: do_alloc_wrk + type(mld_dmlprec_wrk_type), allocatable, target :: mlprec_wrk(:) name='mld_dmlprec_aply' info = psb_success_ @@ -245,34 +242,15 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) & ' Entry ', size(p%precv) trans_ = psb_toupper(trans) - nlev = size(p%precv) - allocate(mlprec_wrk(nlev),stat=info) + nlev = size(p%precv) + + do_alloc_wrk = .not.allocated(p%wrk) + + if (do_alloc_wrk) call p%allocate_wrk(info,vmold=x%v) 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(mlprec_wrk(level)%vx2l,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vtx,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vty,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - if (psb_errstatus_fatal()) then - nc2l = p%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 ! ! At first iteration we must use the input BETA ! @@ -280,31 +258,35 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) level = 1 - call psb_geaxpby(done,x,dzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) + call psb_geaxpby(done,x,dzero,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='geaxbpy') + goto 9999 + end if do isweep = 1, p%outer_sweeps - 1 ! ! With the current implementation, y2l is zeroed internally at first smoother. - ! call mlprec_wrk(level)%vy2l%zero() + ! call p%wrk(level)%vy2l%zero() ! - call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) + call inner_ml_aply(level,p,trans_,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Inner prec aply') goto 9999 end if - call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta_,y,& + call psb_geaxpby(alpha,p%wrk(level)%vy2l,beta_,y,& & p%precv(level)%base_desc,info) ! all iterations after the first must use BETA = 1 beta_ = done ! ! Next iteration should use the current residual to compute a correction ! - call psb_geaxpby(done,x,dzero,mlprec_wrk(level)%vx2l,& + call psb_geaxpby(done,x,dzero,p%wrk(level)%vx2l,& & p%precv(level)%base_desc,info) call psb_spmm(-done,p%precv(level)%base_a,y,& - & done,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) + & done,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) end do ! @@ -314,40 +296,24 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) ! ! With the current implementation, y2l is zeroed internally at first smoother. - ! call mlprec_wrk(level)%vy2l%zero() + ! call p%wrk(level)%vy2l%zero() ! - call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) + call inner_ml_aply(level,p,trans_,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Inner prec aply') goto 9999 end if - - call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta_,y,& + call psb_geaxpby(alpha,p%wrk(level)%vy2l,beta_,y,& & p%precv(level)%base_desc,info) - - do level = 1, nlev - - call mlprec_wrk(level)%vx2l%free(info) - call mlprec_wrk(level)%vy2l%free(info) - call mlprec_wrk(level)%vtx%free(info) - call mlprec_wrk(level)%vty%free(info) - if (psb_errstatus_fatal()) then - info=psb_err_alloc_request_ - nc2l = p%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 if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error final update') goto 9999 end if - + if (do_alloc_wrk) call p%free_wrk(info) call psb_erractionrestore(err_act) return @@ -379,14 +345,13 @@ contains ! between level and level+1 are stored at level+1. ! ! - recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info) + recursive subroutine inner_ml_aply(level,p,trans,work,info) implicit none ! Arguments integer(psb_ipk_) :: level type(mld_dprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) character, intent(in) :: trans real(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(out) :: info @@ -419,7 +384,7 @@ contains call psb_info(ictxt, me, np) if(debug_level > 1) then - write(debug_unit,*) me,' Start inner_ml_aply at level ',level + write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info end if select case(p%precv(level)%parms%ml_cycle) @@ -434,15 +399,15 @@ contains case(mld_add_ml_) - call mld_d_inner_add(p, mlprec_wrk, level, trans, work) + call mld_d_inner_add(p, level, trans, work) case(mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_) - call mld_d_inner_mult(p, mlprec_wrk, level, trans, work) + call mld_d_inner_mult(p, level, trans, work) case(mld_kcycle_ml_, mld_kcyclesym_ml_) - call mld_d_inner_k_cycle(p, mlprec_wrk, level, trans, work) + call mld_d_inner_k_cycle(p, level, trans, work) case default info = psb_err_from_subroutine_ai_ @@ -464,7 +429,7 @@ contains end subroutine inner_ml_aply - recursive subroutine mld_d_inner_add(p, mlprec_wrk, level, trans, work) + recursive subroutine mld_d_inner_add(p, level, trans, work) use psb_base_mod use mld_prec_mod @@ -473,7 +438,6 @@ contains !Input/Oputput variables type(mld_dprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans real(psb_dpk_),target :: work(:) @@ -517,18 +481,18 @@ contains if (allocated(p%precv(level)%sm2a)) then call psb_geaxpby(done,& - & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,dzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc,info) sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post) do k=1, sweeps call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%vy2l,dzero,mlprec_wrk(level)%vtx,& + & p%wrk(level)%vy2l,dzero,p%wrk(level)%vtx,& & p%precv(level)%base_desc, trans,& & ione,work,info,init='Z') call p%precv(level)%sm2a%apply(done,& - & mlprec_wrk(level)%vtx,dzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vtx,dzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & ione,work,info,init='Z') end do @@ -536,7 +500,7 @@ contains else sweeps = p%precv(level)%parms%sweeps_pre call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,dzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -548,8 +512,8 @@ contains if (level < nlev) then ! Apply the restriction - call psb_map_X2Y(done,mlprec_wrk(level)%vx2l,& - & dzero,mlprec_wrk(level+1)%vx2l,& + call psb_map_X2Y(done,p%wrk(level)%vx2l,& + & dzero,p%wrk(level+1)%vx2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -557,7 +521,7 @@ contains goto 9999 end if - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,trans,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error in recursive call') @@ -567,8 +531,8 @@ contains ! ! Apply the prolongator ! - call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& - & done,mlprec_wrk(level)%vy2l,& + call psb_map_Y2X(done,p%wrk(level+1)%vy2l,& + & done,p%wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -587,7 +551,7 @@ contains end subroutine mld_d_inner_add - recursive subroutine mld_d_inner_mult(p, mlprec_wrk, level, trans, work) + recursive subroutine mld_d_inner_mult(p, level, trans, work) use psb_base_mod use mld_prec_mod @@ -596,7 +560,6 @@ contains !Input/Oputput variables type(mld_dprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans real(psb_dpk_),target :: work(:) @@ -633,7 +596,6 @@ contains sweeps_pre = p%precv(level)%parms%sweeps_pre pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) - if (level < nlev) then ! @@ -645,13 +607,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,dzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,dzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -662,25 +624,24 @@ contains goto 9999 end if endif - ! ! Compute the residual and call recursively ! if (pre) then - call psb_geaxpby(done,mlprec_wrk(level)%vx2l,& - & dzero,mlprec_wrk(level)%vty,& + call psb_geaxpby(done,p%wrk(level)%vx2l,& + & dzero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,done,mlprec_wrk(level)%vty,& + & p%wrk(level)%vy2l,done,p%wrk(level)%vty,& & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') goto 9999 end if - call psb_map_X2Y(done,mlprec_wrk(level)%vty,& - & dzero,mlprec_wrk(level+1)%vx2l,& + call psb_map_X2Y(done,p%wrk(level)%vty,& + & dzero,p%wrk(level+1)%vx2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -689,8 +650,8 @@ contains end if else ! Shortcut: just transfer x2l. - call psb_map_X2Y(done,mlprec_wrk(level)%vx2l,& - & dzero,mlprec_wrk(level+1)%vx2l,& + call psb_map_X2Y(done,p%wrk(level)%vx2l,& + & dzero,p%wrk(level+1)%vx2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -699,13 +660,13 @@ contains end if endif - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,trans,work,info) ! ! Apply the prolongator ! - call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& - & done,mlprec_wrk(level)%vy2l,& + call psb_map_Y2X(done,p%wrk(level+1)%vy2l,& + & done,p%wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -715,14 +676,14 @@ contains if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then - call psb_geaxpby(done,mlprec_wrk(level)%vx2l,& - & dzero,mlprec_wrk(level)%vty,& + call psb_geaxpby(done,p%wrk(level)%vx2l,& + & dzero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,done,mlprec_wrk(level)%vty,& + & p%wrk(level)%vy2l,done,p%wrk(level)%vty,& & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info == psb_success_) call psb_map_X2Y(done,mlprec_wrk(level)%vty,& - & dzero,mlprec_wrk(level+1)%vx2l,& + if (info == psb_success_) call psb_map_X2Y(done,p%wrk(level)%vty,& + & dzero,p%wrk(level+1)%vx2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -730,10 +691,10 @@ contains goto 9999 end if - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,trans,work,info) - if (info == psb_success_) call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& - & done,mlprec_wrk(level)%vy2l,& + if (info == psb_success_) call psb_map_Y2X(done,p%wrk(level+1)%vy2l,& + & done,p%wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then @@ -746,12 +707,12 @@ contains if (post) then - call psb_geaxpby(done,mlprec_wrk(level)%vx2l,& - & dzero,mlprec_wrk(level)%vty,& + call psb_geaxpby(done,p%wrk(level)%vx2l,& + & dzero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,& - & done,mlprec_wrk(level)%vty,p%precv(level)%base_desc,info,& + & p%wrk(level)%vy2l,& + & done,p%wrk(level)%vty,p%precv(level)%base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -765,13 +726,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & mlprec_wrk(level)%vty,done,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vty,done,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%vty,done,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vty,done,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -788,7 +749,7 @@ contains sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,dzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -808,7 +769,7 @@ contains end subroutine mld_d_inner_mult - recursive subroutine mld_d_inner_k_cycle(p, mlprec_wrk, level, trans, work,u) + recursive subroutine mld_d_inner_k_cycle(p, level, trans, work,u) use psb_base_mod use mld_prec_mod @@ -816,7 +777,6 @@ contains !Input/Oputput variables type(mld_dprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans real(psb_dpk_),target :: work(:) @@ -870,7 +830,7 @@ contains ! sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,dzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') @@ -879,13 +839,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,dzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,dzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -901,12 +861,12 @@ contains ! Compute the residual and call recursively ! - call psb_geaxpby(done,mlprec_wrk(level)%vx2l,& - & dzero,mlprec_wrk(level)%vty,& + call psb_geaxpby(done,p%wrk(level)%vx2l,& + & dzero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,done,mlprec_wrk(level)%vty,& + & p%wrk(level)%vy2l,done,p%wrk(level)%vty,& & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -915,8 +875,8 @@ contains end if ! Apply the restriction - call psb_map_X2Y(done,mlprec_wrk(level)%vty,& - & dzero,mlprec_wrk(level + 1)%vx2l,& + call psb_map_X2Y(done,p%wrk(level)%vty,& + & dzero,p%wrk(level + 1)%vx2l,& & p%precv(level + 1)%map,info,work=work) if (info /= psb_success_) then @@ -929,16 +889,16 @@ contains if (level <= nlev - 2 ) then if (p%precv(level)%parms%ml_cycle == mld_kcyclesym_ml_) then - call mld_dinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'FCG') + call mld_dinneritkcycle(p, level + 1, trans, work, 'FCG') elseif (p%precv(level)%parms%ml_cycle == mld_kcycle_ml_) then - call mld_dinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'GCR') + call mld_dinneritkcycle(p, level + 1, trans, work, 'GCR') else call psb_errpush(psb_err_internal_error_,name,& & a_err='Bad value for ml_cycle') goto 9999 endif else - call inner_ml_aply(level + 1 ,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level + 1 ,p,trans,work,info) endif if (info /= psb_success_) then @@ -950,8 +910,8 @@ contains ! ! Apply the prolongator ! - call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& - & done,mlprec_wrk(level)%vy2l,& + call psb_map_Y2X(done,p%wrk(level+1)%vy2l,& + & done,p%wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then @@ -963,11 +923,11 @@ contains ! ! Compute the residual ! - call psb_geaxpby(done,mlprec_wrk(level)%vx2l,& - & dzero,mlprec_wrk(level)%vty,& + call psb_geaxpby(done,p%wrk(level)%vx2l,& + & dzero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) - call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - & done,mlprec_wrk(level)%vty,p%precv(level)%base_desc,info,& + call psb_spmm(-done,p%precv(level)%base_a,p%wrk(level)%vy2l,& + & done,p%wrk(level)%vty,p%precv(level)%base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -980,13 +940,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & mlprec_wrk(level)%vty,done,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vty,done,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%vty,done,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vty,done,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -1014,7 +974,7 @@ contains end subroutine mld_d_inner_k_cycle - recursive subroutine mld_dinneritkcycle(p, mlprec_wrk, level, trans, work, innersolv) + recursive subroutine mld_dinneritkcycle(p, level, trans, work, innersolv) use psb_base_mod use mld_prec_mod use mld_d_inner_mod, mld_protect_name => mld_dmlprec_aply @@ -1024,7 +984,6 @@ contains !Input/Oputput variables type(mld_dprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans character(len=*), intent(in) :: innersolv @@ -1044,34 +1003,34 @@ contains call psb_geasb(rhs,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) call psb_geasb(w,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) call psb_geasb(v,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) call psb_geasb(v1,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) call psb_geasb(x,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) !Assemble d(0) and d(1) call psb_geasb(d(0),& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) + & scratch=.true.,mold=p%wrk(level)%vy2l%v) call psb_geasb(d(1),& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) + & scratch=.true.,mold=p%wrk(level)%vy2l%v) call x%zero() ! rhs=vx2l and w=rhs - call psb_geaxpby(done,mlprec_wrk(level)%vx2l,dzero,rhs,& + call psb_geaxpby(done,p%wrk(level)%vx2l,dzero,rhs,& & p%precv(level)%base_desc,info) - call psb_geaxpby(done,mlprec_wrk(level)%vx2l,dzero,w,& + call psb_geaxpby(done,p%wrk(level)%vx2l,dzero,w,& & p%precv(level)%base_desc,info) if (psb_errstatus_fatal()) then @@ -1085,12 +1044,12 @@ contains delta0 = psb_genrm2(w, p%precv(level)%base_desc, info) !Apply the preconditioner - call mlprec_wrk(level)%vy2l%zero() + call p%wrk(level)%vy2l%zero() idx=0 - call inner_ml_aply(level,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level,p,trans,work,info) - call psb_geaxpby(done,mlprec_wrk(level)%vy2l,dzero,d(idx),p%precv(level)%base_desc,info) + call psb_geaxpby(done,p%wrk(level)%vy2l,dzero,d(idx),p%precv(level)%base_desc,info) call psb_spmm(done,p%precv(level)%base_a,d(idx),dzero,v,p%precv(level)%base_desc,info) if (info /= psb_success_) then @@ -1128,9 +1087,9 @@ contains idx=mod(iter,2) !Apply preconditioner - call psb_geaxpby(done,w,dzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) - call inner_ml_aply(level,p,mlprec_wrk,trans,work,info) - call psb_geaxpby(done,mlprec_wrk(level)%vy2l,dzero,d(idx),p%precv(level)%base_desc,info) + call psb_geaxpby(done,w,dzero,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) + call inner_ml_aply(level,p,trans,work,info) + call psb_geaxpby(done,p%wrk(level)%vy2l,dzero,d(idx),p%precv(level)%base_desc,info) !Sparse matrix vector product @@ -1165,7 +1124,7 @@ contains call psb_geaxpby(alpha,d(idx),done,x,p%precv(level)%base_desc,info) endif - call psb_geaxpby(done,x,dzero,mlprec_wrk(level)%vy2l,p%precv(level)%base_desc,info) + call psb_geaxpby(done,x,dzero,p%wrk(level)%vy2l,p%precv(level)%base_desc,info) !Free vectors call psb_gefree(v, p%precv(level)%base_desc, info) call psb_gefree(v1, p%precv(level)%base_desc, info) @@ -1217,10 +1176,10 @@ subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level character(len=20) :: name character :: trans_ - type mld_mlprec_wrk_type + type mld_mlwrk_type real(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) - end type mld_mlprec_wrk_type - type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) + end type mld_mlwrk_type + type(mld_mlwrk_type), allocatable, target :: mlwrk(:) name='mld_dmlprec_aply' info = psb_success_ @@ -1238,7 +1197,7 @@ subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) trans_ = psb_toupper(trans) nlev = size(p%precv) - allocate(mlprec_wrk(nlev),stat=info) + allocate(mlwrk(nlev),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 @@ -1246,13 +1205,13 @@ subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) level = 1 do level = 1, nlev - call psb_geasb(mlprec_wrk(level)%x2l,& + call psb_geasb(mlwrk(level)%x2l,& & p%precv(level)%base_desc,info) - call psb_geasb(mlprec_wrk(level)%y2l,& + call psb_geasb(mlwrk(level)%y2l,& & p%precv(level)%base_desc,info) - call psb_geasb(mlprec_wrk(level)%tx,& + call psb_geasb(mlwrk(level)%tx,& & p%precv(level)%base_desc,info) - call psb_geasb(mlprec_wrk(level)%ty,& + call psb_geasb(mlwrk(level)%ty,& & p%precv(level)%base_desc,info) if (psb_errstatus_fatal()) then nc2l = p%precv(level)%base_desc%get_local_cols() @@ -1263,10 +1222,10 @@ subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) end if end do - mlprec_wrk(level)%x2l(:) = x(:) - mlprec_wrk(level)%y2l(:) = dzero + mlwrk(level)%x2l(:) = x(:) + mlwrk(level)%y2l(:) = dzero - call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) + call inner_ml_aply(level,p,mlwrk,trans_,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1274,7 +1233,7 @@ subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) goto 9999 end if - call psb_geaxpby(alpha,mlprec_wrk(level)%y2l,beta,y,& + call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,& & p%precv(level)%base_desc,info) if (info /= psb_success_) then @@ -1315,14 +1274,14 @@ contains ! between level and level+1 are stored at level+1. ! ! - recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info) + recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info) implicit none ! Arguments integer(psb_ipk_) :: level type(mld_dprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) + type(mld_mlwrk_type), intent(inout), target :: mlwrk(:) character, intent(in) :: trans real(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(out) :: info @@ -1370,15 +1329,15 @@ contains case(mld_add_ml_) - call mld_d_inner_add(p, mlprec_wrk, level, trans, work) + call mld_d_inner_add(p, mlwrk, level, trans, work) case(mld_mult_ml_, mld_vcycle_ml_, mld_wcycle_ml_) - call mld_d_inner_mult(p, mlprec_wrk, level, trans, work) + call mld_d_inner_mult(p, mlwrk, level, trans, work) ! !$ case(mld_kcycle_ml_, mld_kcyclesym_ml_) ! !$ -! !$ call mld_d_inner_k_cycle(p, mlprec_wrk, level, trans, work) +! !$ call mld_d_inner_k_cycle(p, mlwrk, level, trans, work) case default info = psb_err_from_subroutine_ai_ @@ -1397,7 +1356,7 @@ contains end subroutine inner_ml_aply - recursive subroutine mld_d_inner_add(p, mlprec_wrk, level, trans, work) + recursive subroutine mld_d_inner_add(p, mlwrk, level, trans, work) use psb_base_mod use mld_prec_mod @@ -1406,7 +1365,7 @@ contains !Input/Oputput variables type(mld_dprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + type(mld_mlwrk_type), target, intent(inout) :: mlwrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans real(psb_dpk_),target :: work(:) @@ -1450,7 +1409,7 @@ contains sweeps = p%precv(level)%parms%sweeps_pre call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then @@ -1461,17 +1420,17 @@ contains if (level < nlev) then ! Apply the restriction - call psb_map_X2Y(done,mlprec_wrk(level)%x2l,& - & dzero,mlprec_wrk(level+1)%x2l,& + call psb_map_X2Y(done,mlwrk(level)%x2l,& + & dzero,mlwrk(level+1)%x2l,& & p%precv(level+1)%map,info,work=work) - mlprec_wrk(level+1)%y2l(:) = dzero + mlwrk(level+1)%y2l(:) = dzero if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') goto 9999 end if - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,mlwrk,trans,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error in recursive call') @@ -1481,8 +1440,8 @@ contains ! ! Apply the prolongator and add correction. ! - call psb_map_Y2X(done,mlprec_wrk(level+1)%y2l,& - & done,mlprec_wrk(level)%y2l,& + call psb_map_Y2X(done,mlwrk(level+1)%y2l,& + & done,mlwrk(level)%y2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1501,7 +1460,7 @@ contains end subroutine mld_d_inner_add - recursive subroutine mld_d_inner_mult(p, mlprec_wrk, level, trans, work) + recursive subroutine mld_d_inner_mult(p, mlwrk, level, trans, work) use psb_base_mod use mld_prec_mod @@ -1510,7 +1469,7 @@ contains !Input/Oputput variables type(mld_dprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + type(mld_mlwrk_type), target, intent(inout) :: mlwrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans real(psb_dpk_),target :: work(:) @@ -1567,13 +1526,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Y') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Y') end if @@ -1589,20 +1548,20 @@ contains ! Compute the residual and call recursively ! if (pre) then - call psb_geaxpby(done,mlprec_wrk(level)%x2l,& - & dzero,mlprec_wrk(level)%ty,& + call psb_geaxpby(done,mlwrk(level)%x2l,& + & dzero,mlwrk(level)%ty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& - & mlprec_wrk(level)%y2l,done,mlprec_wrk(level)%ty,& + & mlwrk(level)%y2l,done,mlwrk(level)%ty,& & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') goto 9999 end if - call psb_map_X2Y(done,mlprec_wrk(level)%ty,& - & dzero,mlprec_wrk(level+1)%x2l,& + call psb_map_X2Y(done,mlwrk(level)%ty,& + & dzero,mlwrk(level+1)%x2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1611,8 +1570,8 @@ contains end if else ! Shortcut: just transfer x2l. - call psb_map_X2Y(done,mlprec_wrk(level)%x2l,& - & dzero,mlprec_wrk(level+1)%x2l,& + call psb_map_X2Y(done,mlwrk(level)%x2l,& + & dzero,mlwrk(level+1)%x2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1621,14 +1580,14 @@ contains end if endif ! First guess is zero - mlprec_wrk(level+1)%y2l(:) = dzero + mlwrk(level+1)%y2l(:) = dzero - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,mlwrk,trans,work,info) if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then ! On second call will use output y2l as initial guess - if (info == psb_success_) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info) endif if (info /= psb_success_) then @@ -1641,8 +1600,8 @@ contains ! ! Apply the prolongator ! - call psb_map_Y2X(done,mlprec_wrk(level+1)%y2l,& - & done,mlprec_wrk(level)%y2l,& + call psb_map_Y2X(done,mlwrk(level+1)%y2l,& + & done,mlwrk(level)%y2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1654,11 +1613,11 @@ contains ! Compute the residual ! if (post) then - call psb_geaxpby(done,mlprec_wrk(level)%x2l,& - & dzero,mlprec_wrk(level)%tx,& + call psb_geaxpby(done,mlwrk(level)%x2l,& + & dzero,mlwrk(level)%tx,& & p%precv(level)%base_desc,info) - call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& - & done,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,& + call psb_spmm(-done,p%precv(level)%base_a,mlwrk(level)%y2l,& + & done,mlwrk(level)%tx,p%precv(level)%base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1671,13 +1630,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & mlprec_wrk(level)%tx,done,mlprec_wrk(level)%y2l,& + & mlwrk(level)%tx,done,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%tx,done,mlprec_wrk(level)%y2l,& + & mlwrk(level)%tx,done,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -1694,7 +1653,7 @@ contains sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) diff --git a/mlprec/impl/mld_smlprec_aply.f90 b/mlprec/impl/mld_smlprec_aply.f90 index d247be05..5b1ed296 100644 --- a/mlprec/impl/mld_smlprec_aply.f90 +++ b/mlprec/impl/mld_smlprec_aply.f90 @@ -225,11 +225,8 @@ subroutine mld_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) character(len=20) :: name character :: trans_ real(psb_spk_) :: beta_ - type mld_mlprec_wrk_type - real(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) - type(psb_s_vect_type) :: vtx, vty, vx2l, vy2l - end type mld_mlprec_wrk_type - type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) + logical :: do_alloc_wrk + type(mld_smlprec_wrk_type), allocatable, target :: mlprec_wrk(:) name='mld_smlprec_aply' info = psb_success_ @@ -245,34 +242,15 @@ subroutine mld_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) & ' Entry ', size(p%precv) trans_ = psb_toupper(trans) - nlev = size(p%precv) - allocate(mlprec_wrk(nlev),stat=info) + nlev = size(p%precv) + + do_alloc_wrk = .not.allocated(p%wrk) + + if (do_alloc_wrk) call p%allocate_wrk(info,vmold=x%v) 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(mlprec_wrk(level)%vx2l,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vtx,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vty,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - if (psb_errstatus_fatal()) then - nc2l = p%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 ! ! At first iteration we must use the input BETA ! @@ -280,31 +258,35 @@ subroutine mld_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) level = 1 - call psb_geaxpby(sone,x,szero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) + call psb_geaxpby(sone,x,szero,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='geaxbpy') + goto 9999 + end if do isweep = 1, p%outer_sweeps - 1 ! ! With the current implementation, y2l is zeroed internally at first smoother. - ! call mlprec_wrk(level)%vy2l%zero() + ! call p%wrk(level)%vy2l%zero() ! - call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) + call inner_ml_aply(level,p,trans_,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Inner prec aply') goto 9999 end if - call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta_,y,& + call psb_geaxpby(alpha,p%wrk(level)%vy2l,beta_,y,& & p%precv(level)%base_desc,info) ! all iterations after the first must use BETA = 1 beta_ = sone ! ! Next iteration should use the current residual to compute a correction ! - call psb_geaxpby(sone,x,szero,mlprec_wrk(level)%vx2l,& + call psb_geaxpby(sone,x,szero,p%wrk(level)%vx2l,& & p%precv(level)%base_desc,info) call psb_spmm(-sone,p%precv(level)%base_a,y,& - & sone,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) + & sone,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) end do ! @@ -314,40 +296,24 @@ subroutine mld_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) ! ! With the current implementation, y2l is zeroed internally at first smoother. - ! call mlprec_wrk(level)%vy2l%zero() + ! call p%wrk(level)%vy2l%zero() ! - call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) + call inner_ml_aply(level,p,trans_,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Inner prec aply') goto 9999 end if - - call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta_,y,& + call psb_geaxpby(alpha,p%wrk(level)%vy2l,beta_,y,& & p%precv(level)%base_desc,info) - - do level = 1, nlev - - call mlprec_wrk(level)%vx2l%free(info) - call mlprec_wrk(level)%vy2l%free(info) - call mlprec_wrk(level)%vtx%free(info) - call mlprec_wrk(level)%vty%free(info) - if (psb_errstatus_fatal()) then - info=psb_err_alloc_request_ - nc2l = p%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 if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error final update') goto 9999 end if - + if (do_alloc_wrk) call p%free_wrk(info) call psb_erractionrestore(err_act) return @@ -379,14 +345,13 @@ contains ! between level and level+1 are stored at level+1. ! ! - recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info) + recursive subroutine inner_ml_aply(level,p,trans,work,info) implicit none ! Arguments integer(psb_ipk_) :: level type(mld_sprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) character, intent(in) :: trans real(psb_spk_),target :: work(:) integer(psb_ipk_), intent(out) :: info @@ -419,7 +384,7 @@ contains call psb_info(ictxt, me, np) if(debug_level > 1) then - write(debug_unit,*) me,' Start inner_ml_aply at level ',level + write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info end if select case(p%precv(level)%parms%ml_cycle) @@ -434,15 +399,15 @@ contains case(mld_add_ml_) - call mld_s_inner_add(p, mlprec_wrk, level, trans, work) + call mld_s_inner_add(p, level, trans, work) case(mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_) - call mld_s_inner_mult(p, mlprec_wrk, level, trans, work) + call mld_s_inner_mult(p, level, trans, work) case(mld_kcycle_ml_, mld_kcyclesym_ml_) - call mld_s_inner_k_cycle(p, mlprec_wrk, level, trans, work) + call mld_s_inner_k_cycle(p, level, trans, work) case default info = psb_err_from_subroutine_ai_ @@ -464,7 +429,7 @@ contains end subroutine inner_ml_aply - recursive subroutine mld_s_inner_add(p, mlprec_wrk, level, trans, work) + recursive subroutine mld_s_inner_add(p, level, trans, work) use psb_base_mod use mld_prec_mod @@ -473,7 +438,6 @@ contains !Input/Oputput variables type(mld_sprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans real(psb_spk_),target :: work(:) @@ -517,18 +481,18 @@ contains if (allocated(p%precv(level)%sm2a)) then call psb_geaxpby(sone,& - & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,szero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc,info) sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post) do k=1, sweeps call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%vy2l,szero,mlprec_wrk(level)%vtx,& + & p%wrk(level)%vy2l,szero,p%wrk(level)%vtx,& & p%precv(level)%base_desc, trans,& & ione,work,info,init='Z') call p%precv(level)%sm2a%apply(sone,& - & mlprec_wrk(level)%vtx,szero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vtx,szero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & ione,work,info,init='Z') end do @@ -536,7 +500,7 @@ contains else sweeps = p%precv(level)%parms%sweeps_pre call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,szero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -548,8 +512,8 @@ contains if (level < nlev) then ! Apply the restriction - call psb_map_X2Y(sone,mlprec_wrk(level)%vx2l,& - & szero,mlprec_wrk(level+1)%vx2l,& + call psb_map_X2Y(sone,p%wrk(level)%vx2l,& + & szero,p%wrk(level+1)%vx2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -557,7 +521,7 @@ contains goto 9999 end if - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,trans,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error in recursive call') @@ -567,8 +531,8 @@ contains ! ! Apply the prolongator ! - call psb_map_Y2X(sone,mlprec_wrk(level+1)%vy2l,& - & sone,mlprec_wrk(level)%vy2l,& + call psb_map_Y2X(sone,p%wrk(level+1)%vy2l,& + & sone,p%wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -587,7 +551,7 @@ contains end subroutine mld_s_inner_add - recursive subroutine mld_s_inner_mult(p, mlprec_wrk, level, trans, work) + recursive subroutine mld_s_inner_mult(p, level, trans, work) use psb_base_mod use mld_prec_mod @@ -596,7 +560,6 @@ contains !Input/Oputput variables type(mld_sprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans real(psb_spk_),target :: work(:) @@ -633,7 +596,6 @@ contains sweeps_pre = p%precv(level)%parms%sweeps_pre pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) - if (level < nlev) then ! @@ -645,13 +607,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,szero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& - & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,szero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -662,25 +624,24 @@ contains goto 9999 end if endif - ! ! Compute the residual and call recursively ! if (pre) then - call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,& - & szero,mlprec_wrk(level)%vty,& + call psb_geaxpby(sone,p%wrk(level)%vx2l,& + & szero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,sone,mlprec_wrk(level)%vty,& + & p%wrk(level)%vy2l,sone,p%wrk(level)%vty,& & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') goto 9999 end if - call psb_map_X2Y(sone,mlprec_wrk(level)%vty,& - & szero,mlprec_wrk(level+1)%vx2l,& + call psb_map_X2Y(sone,p%wrk(level)%vty,& + & szero,p%wrk(level+1)%vx2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -689,8 +650,8 @@ contains end if else ! Shortcut: just transfer x2l. - call psb_map_X2Y(sone,mlprec_wrk(level)%vx2l,& - & szero,mlprec_wrk(level+1)%vx2l,& + call psb_map_X2Y(sone,p%wrk(level)%vx2l,& + & szero,p%wrk(level+1)%vx2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -699,13 +660,13 @@ contains end if endif - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,trans,work,info) ! ! Apply the prolongator ! - call psb_map_Y2X(sone,mlprec_wrk(level+1)%vy2l,& - & sone,mlprec_wrk(level)%vy2l,& + call psb_map_Y2X(sone,p%wrk(level+1)%vy2l,& + & sone,p%wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -715,14 +676,14 @@ contains if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then - call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,& - & szero,mlprec_wrk(level)%vty,& + call psb_geaxpby(sone,p%wrk(level)%vx2l,& + & szero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,sone,mlprec_wrk(level)%vty,& + & p%wrk(level)%vy2l,sone,p%wrk(level)%vty,& & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info == psb_success_) call psb_map_X2Y(sone,mlprec_wrk(level)%vty,& - & szero,mlprec_wrk(level+1)%vx2l,& + if (info == psb_success_) call psb_map_X2Y(sone,p%wrk(level)%vty,& + & szero,p%wrk(level+1)%vx2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -730,10 +691,10 @@ contains goto 9999 end if - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,trans,work,info) - if (info == psb_success_) call psb_map_Y2X(sone,mlprec_wrk(level+1)%vy2l,& - & sone,mlprec_wrk(level)%vy2l,& + if (info == psb_success_) call psb_map_Y2X(sone,p%wrk(level+1)%vy2l,& + & sone,p%wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then @@ -746,12 +707,12 @@ contains if (post) then - call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,& - & szero,mlprec_wrk(level)%vty,& + call psb_geaxpby(sone,p%wrk(level)%vx2l,& + & szero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,& - & sone,mlprec_wrk(level)%vty,p%precv(level)%base_desc,info,& + & p%wrk(level)%vy2l,& + & sone,p%wrk(level)%vty,p%precv(level)%base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -765,13 +726,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& - & mlprec_wrk(level)%vty,sone,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vty,sone,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%vty,sone,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vty,sone,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -788,7 +749,7 @@ contains sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,szero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -808,7 +769,7 @@ contains end subroutine mld_s_inner_mult - recursive subroutine mld_s_inner_k_cycle(p, mlprec_wrk, level, trans, work,u) + recursive subroutine mld_s_inner_k_cycle(p, level, trans, work,u) use psb_base_mod use mld_prec_mod @@ -816,7 +777,6 @@ contains !Input/Oputput variables type(mld_sprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans real(psb_spk_),target :: work(:) @@ -870,7 +830,7 @@ contains ! sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,szero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') @@ -879,13 +839,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,szero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& - & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,szero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -901,12 +861,12 @@ contains ! Compute the residual and call recursively ! - call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,& - & szero,mlprec_wrk(level)%vty,& + call psb_geaxpby(sone,p%wrk(level)%vx2l,& + & szero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,sone,mlprec_wrk(level)%vty,& + & p%wrk(level)%vy2l,sone,p%wrk(level)%vty,& & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -915,8 +875,8 @@ contains end if ! Apply the restriction - call psb_map_X2Y(sone,mlprec_wrk(level)%vty,& - & szero,mlprec_wrk(level + 1)%vx2l,& + call psb_map_X2Y(sone,p%wrk(level)%vty,& + & szero,p%wrk(level + 1)%vx2l,& & p%precv(level + 1)%map,info,work=work) if (info /= psb_success_) then @@ -929,16 +889,16 @@ contains if (level <= nlev - 2 ) then if (p%precv(level)%parms%ml_cycle == mld_kcyclesym_ml_) then - call mld_sinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'FCG') + call mld_sinneritkcycle(p, level + 1, trans, work, 'FCG') elseif (p%precv(level)%parms%ml_cycle == mld_kcycle_ml_) then - call mld_sinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'GCR') + call mld_sinneritkcycle(p, level + 1, trans, work, 'GCR') else call psb_errpush(psb_err_internal_error_,name,& & a_err='Bad value for ml_cycle') goto 9999 endif else - call inner_ml_aply(level + 1 ,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level + 1 ,p,trans,work,info) endif if (info /= psb_success_) then @@ -950,8 +910,8 @@ contains ! ! Apply the prolongator ! - call psb_map_Y2X(sone,mlprec_wrk(level+1)%vy2l,& - & sone,mlprec_wrk(level)%vy2l,& + call psb_map_Y2X(sone,p%wrk(level+1)%vy2l,& + & sone,p%wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then @@ -963,11 +923,11 @@ contains ! ! Compute the residual ! - call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,& - & szero,mlprec_wrk(level)%vty,& + call psb_geaxpby(sone,p%wrk(level)%vx2l,& + & szero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) - call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - & sone,mlprec_wrk(level)%vty,p%precv(level)%base_desc,info,& + call psb_spmm(-sone,p%precv(level)%base_a,p%wrk(level)%vy2l,& + & sone,p%wrk(level)%vty,p%precv(level)%base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -980,13 +940,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& - & mlprec_wrk(level)%vty,sone,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vty,sone,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%vty,sone,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vty,sone,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -1014,7 +974,7 @@ contains end subroutine mld_s_inner_k_cycle - recursive subroutine mld_sinneritkcycle(p, mlprec_wrk, level, trans, work, innersolv) + recursive subroutine mld_sinneritkcycle(p, level, trans, work, innersolv) use psb_base_mod use mld_prec_mod use mld_s_inner_mod, mld_protect_name => mld_smlprec_aply @@ -1024,7 +984,6 @@ contains !Input/Oputput variables type(mld_sprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans character(len=*), intent(in) :: innersolv @@ -1044,34 +1003,34 @@ contains call psb_geasb(rhs,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) call psb_geasb(w,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) call psb_geasb(v,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) call psb_geasb(v1,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) call psb_geasb(x,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) !Assemble d(0) and d(1) call psb_geasb(d(0),& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) + & scratch=.true.,mold=p%wrk(level)%vy2l%v) call psb_geasb(d(1),& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) + & scratch=.true.,mold=p%wrk(level)%vy2l%v) call x%zero() ! rhs=vx2l and w=rhs - call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,szero,rhs,& + call psb_geaxpby(sone,p%wrk(level)%vx2l,szero,rhs,& & p%precv(level)%base_desc,info) - call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,szero,w,& + call psb_geaxpby(sone,p%wrk(level)%vx2l,szero,w,& & p%precv(level)%base_desc,info) if (psb_errstatus_fatal()) then @@ -1085,12 +1044,12 @@ contains delta0 = psb_genrm2(w, p%precv(level)%base_desc, info) !Apply the preconditioner - call mlprec_wrk(level)%vy2l%zero() + call p%wrk(level)%vy2l%zero() idx=0 - call inner_ml_aply(level,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level,p,trans,work,info) - call psb_geaxpby(sone,mlprec_wrk(level)%vy2l,szero,d(idx),p%precv(level)%base_desc,info) + call psb_geaxpby(sone,p%wrk(level)%vy2l,szero,d(idx),p%precv(level)%base_desc,info) call psb_spmm(sone,p%precv(level)%base_a,d(idx),szero,v,p%precv(level)%base_desc,info) if (info /= psb_success_) then @@ -1128,9 +1087,9 @@ contains idx=mod(iter,2) !Apply preconditioner - call psb_geaxpby(sone,w,szero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) - call inner_ml_aply(level,p,mlprec_wrk,trans,work,info) - call psb_geaxpby(sone,mlprec_wrk(level)%vy2l,szero,d(idx),p%precv(level)%base_desc,info) + call psb_geaxpby(sone,w,szero,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) + call inner_ml_aply(level,p,trans,work,info) + call psb_geaxpby(sone,p%wrk(level)%vy2l,szero,d(idx),p%precv(level)%base_desc,info) !Sparse matrix vector product @@ -1165,7 +1124,7 @@ contains call psb_geaxpby(alpha,d(idx),sone,x,p%precv(level)%base_desc,info) endif - call psb_geaxpby(sone,x,szero,mlprec_wrk(level)%vy2l,p%precv(level)%base_desc,info) + call psb_geaxpby(sone,x,szero,p%wrk(level)%vy2l,p%precv(level)%base_desc,info) !Free vectors call psb_gefree(v, p%precv(level)%base_desc, info) call psb_gefree(v1, p%precv(level)%base_desc, info) @@ -1217,10 +1176,10 @@ subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level character(len=20) :: name character :: trans_ - type mld_mlprec_wrk_type + type mld_mlwrk_type real(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) - end type mld_mlprec_wrk_type - type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) + end type mld_mlwrk_type + type(mld_mlwrk_type), allocatable, target :: mlwrk(:) name='mld_smlprec_aply' info = psb_success_ @@ -1238,7 +1197,7 @@ subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) trans_ = psb_toupper(trans) nlev = size(p%precv) - allocate(mlprec_wrk(nlev),stat=info) + allocate(mlwrk(nlev),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 @@ -1246,13 +1205,13 @@ subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) level = 1 do level = 1, nlev - call psb_geasb(mlprec_wrk(level)%x2l,& + call psb_geasb(mlwrk(level)%x2l,& & p%precv(level)%base_desc,info) - call psb_geasb(mlprec_wrk(level)%y2l,& + call psb_geasb(mlwrk(level)%y2l,& & p%precv(level)%base_desc,info) - call psb_geasb(mlprec_wrk(level)%tx,& + call psb_geasb(mlwrk(level)%tx,& & p%precv(level)%base_desc,info) - call psb_geasb(mlprec_wrk(level)%ty,& + call psb_geasb(mlwrk(level)%ty,& & p%precv(level)%base_desc,info) if (psb_errstatus_fatal()) then nc2l = p%precv(level)%base_desc%get_local_cols() @@ -1263,10 +1222,10 @@ subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) end if end do - mlprec_wrk(level)%x2l(:) = x(:) - mlprec_wrk(level)%y2l(:) = szero + mlwrk(level)%x2l(:) = x(:) + mlwrk(level)%y2l(:) = szero - call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) + call inner_ml_aply(level,p,mlwrk,trans_,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1274,7 +1233,7 @@ subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) goto 9999 end if - call psb_geaxpby(alpha,mlprec_wrk(level)%y2l,beta,y,& + call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,& & p%precv(level)%base_desc,info) if (info /= psb_success_) then @@ -1315,14 +1274,14 @@ contains ! between level and level+1 are stored at level+1. ! ! - recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info) + recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info) implicit none ! Arguments integer(psb_ipk_) :: level type(mld_sprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) + type(mld_mlwrk_type), intent(inout), target :: mlwrk(:) character, intent(in) :: trans real(psb_spk_),target :: work(:) integer(psb_ipk_), intent(out) :: info @@ -1370,15 +1329,15 @@ contains case(mld_add_ml_) - call mld_s_inner_add(p, mlprec_wrk, level, trans, work) + call mld_s_inner_add(p, mlwrk, level, trans, work) case(mld_mult_ml_, mld_vcycle_ml_, mld_wcycle_ml_) - call mld_s_inner_mult(p, mlprec_wrk, level, trans, work) + call mld_s_inner_mult(p, mlwrk, level, trans, work) ! !$ case(mld_kcycle_ml_, mld_kcyclesym_ml_) ! !$ -! !$ call mld_s_inner_k_cycle(p, mlprec_wrk, level, trans, work) +! !$ call mld_s_inner_k_cycle(p, mlwrk, level, trans, work) case default info = psb_err_from_subroutine_ai_ @@ -1397,7 +1356,7 @@ contains end subroutine inner_ml_aply - recursive subroutine mld_s_inner_add(p, mlprec_wrk, level, trans, work) + recursive subroutine mld_s_inner_add(p, mlwrk, level, trans, work) use psb_base_mod use mld_prec_mod @@ -1406,7 +1365,7 @@ contains !Input/Oputput variables type(mld_sprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + type(mld_mlwrk_type), target, intent(inout) :: mlwrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans real(psb_spk_),target :: work(:) @@ -1450,7 +1409,7 @@ contains sweeps = p%precv(level)%parms%sweeps_pre call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& + & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then @@ -1461,17 +1420,17 @@ contains if (level < nlev) then ! Apply the restriction - call psb_map_X2Y(sone,mlprec_wrk(level)%x2l,& - & szero,mlprec_wrk(level+1)%x2l,& + call psb_map_X2Y(sone,mlwrk(level)%x2l,& + & szero,mlwrk(level+1)%x2l,& & p%precv(level+1)%map,info,work=work) - mlprec_wrk(level+1)%y2l(:) = szero + mlwrk(level+1)%y2l(:) = szero if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') goto 9999 end if - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,mlwrk,trans,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error in recursive call') @@ -1481,8 +1440,8 @@ contains ! ! Apply the prolongator and add correction. ! - call psb_map_Y2X(sone,mlprec_wrk(level+1)%y2l,& - & sone,mlprec_wrk(level)%y2l,& + call psb_map_Y2X(sone,mlwrk(level+1)%y2l,& + & sone,mlwrk(level)%y2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1501,7 +1460,7 @@ contains end subroutine mld_s_inner_add - recursive subroutine mld_s_inner_mult(p, mlprec_wrk, level, trans, work) + recursive subroutine mld_s_inner_mult(p, mlwrk, level, trans, work) use psb_base_mod use mld_prec_mod @@ -1510,7 +1469,7 @@ contains !Input/Oputput variables type(mld_sprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + type(mld_mlwrk_type), target, intent(inout) :: mlwrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans real(psb_spk_),target :: work(:) @@ -1567,13 +1526,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& + & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Y') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& - & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& + & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Y') end if @@ -1589,20 +1548,20 @@ contains ! Compute the residual and call recursively ! if (pre) then - call psb_geaxpby(sone,mlprec_wrk(level)%x2l,& - & szero,mlprec_wrk(level)%ty,& + call psb_geaxpby(sone,mlwrk(level)%x2l,& + & szero,mlwrk(level)%ty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& - & mlprec_wrk(level)%y2l,sone,mlprec_wrk(level)%ty,& + & mlwrk(level)%y2l,sone,mlwrk(level)%ty,& & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') goto 9999 end if - call psb_map_X2Y(sone,mlprec_wrk(level)%ty,& - & szero,mlprec_wrk(level+1)%x2l,& + call psb_map_X2Y(sone,mlwrk(level)%ty,& + & szero,mlwrk(level+1)%x2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1611,8 +1570,8 @@ contains end if else ! Shortcut: just transfer x2l. - call psb_map_X2Y(sone,mlprec_wrk(level)%x2l,& - & szero,mlprec_wrk(level+1)%x2l,& + call psb_map_X2Y(sone,mlwrk(level)%x2l,& + & szero,mlwrk(level+1)%x2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1621,14 +1580,14 @@ contains end if endif ! First guess is zero - mlprec_wrk(level+1)%y2l(:) = szero + mlwrk(level+1)%y2l(:) = szero - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,mlwrk,trans,work,info) if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then ! On second call will use output y2l as initial guess - if (info == psb_success_) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info) endif if (info /= psb_success_) then @@ -1641,8 +1600,8 @@ contains ! ! Apply the prolongator ! - call psb_map_Y2X(sone,mlprec_wrk(level+1)%y2l,& - & sone,mlprec_wrk(level)%y2l,& + call psb_map_Y2X(sone,mlwrk(level+1)%y2l,& + & sone,mlwrk(level)%y2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1654,11 +1613,11 @@ contains ! Compute the residual ! if (post) then - call psb_geaxpby(sone,mlprec_wrk(level)%x2l,& - & szero,mlprec_wrk(level)%tx,& + call psb_geaxpby(sone,mlwrk(level)%x2l,& + & szero,mlwrk(level)%tx,& & p%precv(level)%base_desc,info) - call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& - & sone,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,& + call psb_spmm(-sone,p%precv(level)%base_a,mlwrk(level)%y2l,& + & sone,mlwrk(level)%tx,p%precv(level)%base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1671,13 +1630,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& - & mlprec_wrk(level)%tx,sone,mlprec_wrk(level)%y2l,& + & mlwrk(level)%tx,sone,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%tx,sone,mlprec_wrk(level)%y2l,& + & mlwrk(level)%tx,sone,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -1694,7 +1653,7 @@ contains sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& + & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) diff --git a/mlprec/impl/mld_zmlprec_aply.f90 b/mlprec/impl/mld_zmlprec_aply.f90 index 416c8dca..bf7d7e48 100644 --- a/mlprec/impl/mld_zmlprec_aply.f90 +++ b/mlprec/impl/mld_zmlprec_aply.f90 @@ -225,11 +225,8 @@ subroutine mld_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) character(len=20) :: name character :: trans_ complex(psb_dpk_) :: beta_ - type mld_mlprec_wrk_type - complex(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) - type(psb_z_vect_type) :: vtx, vty, vx2l, vy2l - end type mld_mlprec_wrk_type - type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) + logical :: do_alloc_wrk + type(mld_zmlprec_wrk_type), allocatable, target :: mlprec_wrk(:) name='mld_zmlprec_aply' info = psb_success_ @@ -245,34 +242,15 @@ subroutine mld_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) & ' Entry ', size(p%precv) trans_ = psb_toupper(trans) - nlev = size(p%precv) - allocate(mlprec_wrk(nlev),stat=info) + nlev = size(p%precv) + + do_alloc_wrk = .not.allocated(p%wrk) + + if (do_alloc_wrk) call p%allocate_wrk(info,vmold=x%v) 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(mlprec_wrk(level)%vx2l,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vtx,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vty,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - if (psb_errstatus_fatal()) then - nc2l = p%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 ! ! At first iteration we must use the input BETA ! @@ -280,31 +258,35 @@ subroutine mld_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) level = 1 - call psb_geaxpby(zone,x,zzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) + call psb_geaxpby(zone,x,zzero,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='geaxbpy') + goto 9999 + end if do isweep = 1, p%outer_sweeps - 1 ! ! With the current implementation, y2l is zeroed internally at first smoother. - ! call mlprec_wrk(level)%vy2l%zero() + ! call p%wrk(level)%vy2l%zero() ! - call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) + call inner_ml_aply(level,p,trans_,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Inner prec aply') goto 9999 end if - call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta_,y,& + call psb_geaxpby(alpha,p%wrk(level)%vy2l,beta_,y,& & p%precv(level)%base_desc,info) ! all iterations after the first must use BETA = 1 beta_ = zone ! ! Next iteration should use the current residual to compute a correction ! - call psb_geaxpby(zone,x,zzero,mlprec_wrk(level)%vx2l,& + call psb_geaxpby(zone,x,zzero,p%wrk(level)%vx2l,& & p%precv(level)%base_desc,info) call psb_spmm(-zone,p%precv(level)%base_a,y,& - & zone,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) + & zone,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) end do ! @@ -314,40 +296,24 @@ subroutine mld_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) ! ! With the current implementation, y2l is zeroed internally at first smoother. - ! call mlprec_wrk(level)%vy2l%zero() + ! call p%wrk(level)%vy2l%zero() ! - call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) + call inner_ml_aply(level,p,trans_,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Inner prec aply') goto 9999 end if - - call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta_,y,& + call psb_geaxpby(alpha,p%wrk(level)%vy2l,beta_,y,& & p%precv(level)%base_desc,info) - - do level = 1, nlev - - call mlprec_wrk(level)%vx2l%free(info) - call mlprec_wrk(level)%vy2l%free(info) - call mlprec_wrk(level)%vtx%free(info) - call mlprec_wrk(level)%vty%free(info) - if (psb_errstatus_fatal()) then - info=psb_err_alloc_request_ - nc2l = p%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 if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error final update') goto 9999 end if - + if (do_alloc_wrk) call p%free_wrk(info) call psb_erractionrestore(err_act) return @@ -379,14 +345,13 @@ contains ! between level and level+1 are stored at level+1. ! ! - recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info) + recursive subroutine inner_ml_aply(level,p,trans,work,info) implicit none ! Arguments integer(psb_ipk_) :: level type(mld_zprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) character, intent(in) :: trans complex(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(out) :: info @@ -419,7 +384,7 @@ contains call psb_info(ictxt, me, np) if(debug_level > 1) then - write(debug_unit,*) me,' Start inner_ml_aply at level ',level + write(debug_unit,*) me,' Start inner_ml_aply at level ',level, info end if select case(p%precv(level)%parms%ml_cycle) @@ -434,15 +399,15 @@ contains case(mld_add_ml_) - call mld_z_inner_add(p, mlprec_wrk, level, trans, work) + call mld_z_inner_add(p, level, trans, work) case(mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_) - call mld_z_inner_mult(p, mlprec_wrk, level, trans, work) + call mld_z_inner_mult(p, level, trans, work) case(mld_kcycle_ml_, mld_kcyclesym_ml_) - call mld_z_inner_k_cycle(p, mlprec_wrk, level, trans, work) + call mld_z_inner_k_cycle(p, level, trans, work) case default info = psb_err_from_subroutine_ai_ @@ -464,7 +429,7 @@ contains end subroutine inner_ml_aply - recursive subroutine mld_z_inner_add(p, mlprec_wrk, level, trans, work) + recursive subroutine mld_z_inner_add(p, level, trans, work) use psb_base_mod use mld_prec_mod @@ -473,7 +438,6 @@ contains !Input/Oputput variables type(mld_zprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans complex(psb_dpk_),target :: work(:) @@ -517,18 +481,18 @@ contains if (allocated(p%precv(level)%sm2a)) then call psb_geaxpby(zone,& - & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,zzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc,info) sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post) do k=1, sweeps call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%vy2l,zzero,mlprec_wrk(level)%vtx,& + & p%wrk(level)%vy2l,zzero,p%wrk(level)%vtx,& & p%precv(level)%base_desc, trans,& & ione,work,info,init='Z') call p%precv(level)%sm2a%apply(zone,& - & mlprec_wrk(level)%vtx,zzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vtx,zzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & ione,work,info,init='Z') end do @@ -536,7 +500,7 @@ contains else sweeps = p%precv(level)%parms%sweeps_pre call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,zzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -548,8 +512,8 @@ contains if (level < nlev) then ! Apply the restriction - call psb_map_X2Y(zone,mlprec_wrk(level)%vx2l,& - & zzero,mlprec_wrk(level+1)%vx2l,& + call psb_map_X2Y(zone,p%wrk(level)%vx2l,& + & zzero,p%wrk(level+1)%vx2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -557,7 +521,7 @@ contains goto 9999 end if - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,trans,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error in recursive call') @@ -567,8 +531,8 @@ contains ! ! Apply the prolongator ! - call psb_map_Y2X(zone,mlprec_wrk(level+1)%vy2l,& - & zone,mlprec_wrk(level)%vy2l,& + call psb_map_Y2X(zone,p%wrk(level+1)%vy2l,& + & zone,p%wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -587,7 +551,7 @@ contains end subroutine mld_z_inner_add - recursive subroutine mld_z_inner_mult(p, mlprec_wrk, level, trans, work) + recursive subroutine mld_z_inner_mult(p, level, trans, work) use psb_base_mod use mld_prec_mod @@ -596,7 +560,6 @@ contains !Input/Oputput variables type(mld_zprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans complex(psb_dpk_),target :: work(:) @@ -633,7 +596,6 @@ contains sweeps_pre = p%precv(level)%parms%sweeps_pre pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) - if (level < nlev) then ! @@ -645,13 +607,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,zzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& - & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,zzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -662,25 +624,24 @@ contains goto 9999 end if endif - ! ! Compute the residual and call recursively ! if (pre) then - call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,& - & zzero,mlprec_wrk(level)%vty,& + call psb_geaxpby(zone,p%wrk(level)%vx2l,& + & zzero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,zone,mlprec_wrk(level)%vty,& + & p%wrk(level)%vy2l,zone,p%wrk(level)%vty,& & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') goto 9999 end if - call psb_map_X2Y(zone,mlprec_wrk(level)%vty,& - & zzero,mlprec_wrk(level+1)%vx2l,& + call psb_map_X2Y(zone,p%wrk(level)%vty,& + & zzero,p%wrk(level+1)%vx2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -689,8 +650,8 @@ contains end if else ! Shortcut: just transfer x2l. - call psb_map_X2Y(zone,mlprec_wrk(level)%vx2l,& - & zzero,mlprec_wrk(level+1)%vx2l,& + call psb_map_X2Y(zone,p%wrk(level)%vx2l,& + & zzero,p%wrk(level+1)%vx2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -699,13 +660,13 @@ contains end if endif - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,trans,work,info) ! ! Apply the prolongator ! - call psb_map_Y2X(zone,mlprec_wrk(level+1)%vy2l,& - & zone,mlprec_wrk(level)%vy2l,& + call psb_map_Y2X(zone,p%wrk(level+1)%vy2l,& + & zone,p%wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -715,14 +676,14 @@ contains if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then - call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,& - & zzero,mlprec_wrk(level)%vty,& + call psb_geaxpby(zone,p%wrk(level)%vx2l,& + & zzero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,zone,mlprec_wrk(level)%vty,& + & p%wrk(level)%vy2l,zone,p%wrk(level)%vty,& & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info == psb_success_) call psb_map_X2Y(zone,mlprec_wrk(level)%vty,& - & zzero,mlprec_wrk(level+1)%vx2l,& + if (info == psb_success_) call psb_map_X2Y(zone,p%wrk(level)%vty,& + & zzero,p%wrk(level+1)%vx2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -730,10 +691,10 @@ contains goto 9999 end if - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,trans,work,info) - if (info == psb_success_) call psb_map_Y2X(zone,mlprec_wrk(level+1)%vy2l,& - & zone,mlprec_wrk(level)%vy2l,& + if (info == psb_success_) call psb_map_Y2X(zone,p%wrk(level+1)%vy2l,& + & zone,p%wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then @@ -746,12 +707,12 @@ contains if (post) then - call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,& - & zzero,mlprec_wrk(level)%vty,& + call psb_geaxpby(zone,p%wrk(level)%vx2l,& + & zzero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,& - & zone,mlprec_wrk(level)%vty,p%precv(level)%base_desc,info,& + & p%wrk(level)%vy2l,& + & zone,p%wrk(level)%vty,p%precv(level)%base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -765,13 +726,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& - & mlprec_wrk(level)%vty,zone,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vty,zone,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%vty,zone,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vty,zone,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -788,7 +749,7 @@ contains sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,zzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -808,7 +769,7 @@ contains end subroutine mld_z_inner_mult - recursive subroutine mld_z_inner_k_cycle(p, mlprec_wrk, level, trans, work,u) + recursive subroutine mld_z_inner_k_cycle(p, level, trans, work,u) use psb_base_mod use mld_prec_mod @@ -816,7 +777,6 @@ contains !Input/Oputput variables type(mld_zprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans complex(psb_dpk_),target :: work(:) @@ -870,7 +830,7 @@ contains ! sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,zzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') @@ -879,13 +839,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,zzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& - & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vx2l,zzero,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -901,12 +861,12 @@ contains ! Compute the residual and call recursively ! - call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,& - & zzero,mlprec_wrk(level)%vty,& + call psb_geaxpby(zone,p%wrk(level)%vx2l,& + & zzero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,zone,mlprec_wrk(level)%vty,& + & p%wrk(level)%vy2l,zone,p%wrk(level)%vty,& & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -915,8 +875,8 @@ contains end if ! Apply the restriction - call psb_map_X2Y(zone,mlprec_wrk(level)%vty,& - & zzero,mlprec_wrk(level + 1)%vx2l,& + call psb_map_X2Y(zone,p%wrk(level)%vty,& + & zzero,p%wrk(level + 1)%vx2l,& & p%precv(level + 1)%map,info,work=work) if (info /= psb_success_) then @@ -929,16 +889,16 @@ contains if (level <= nlev - 2 ) then if (p%precv(level)%parms%ml_cycle == mld_kcyclesym_ml_) then - call mld_zinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'FCG') + call mld_zinneritkcycle(p, level + 1, trans, work, 'FCG') elseif (p%precv(level)%parms%ml_cycle == mld_kcycle_ml_) then - call mld_zinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'GCR') + call mld_zinneritkcycle(p, level + 1, trans, work, 'GCR') else call psb_errpush(psb_err_internal_error_,name,& & a_err='Bad value for ml_cycle') goto 9999 endif else - call inner_ml_aply(level + 1 ,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level + 1 ,p,trans,work,info) endif if (info /= psb_success_) then @@ -950,8 +910,8 @@ contains ! ! Apply the prolongator ! - call psb_map_Y2X(zone,mlprec_wrk(level+1)%vy2l,& - & zone,mlprec_wrk(level)%vy2l,& + call psb_map_Y2X(zone,p%wrk(level+1)%vy2l,& + & zone,p%wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then @@ -963,11 +923,11 @@ contains ! ! Compute the residual ! - call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,& - & zzero,mlprec_wrk(level)%vty,& + call psb_geaxpby(zone,p%wrk(level)%vx2l,& + & zzero,p%wrk(level)%vty,& & p%precv(level)%base_desc,info) - call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - & zone,mlprec_wrk(level)%vty,p%precv(level)%base_desc,info,& + call psb_spmm(-zone,p%precv(level)%base_a,p%wrk(level)%vy2l,& + & zone,p%wrk(level)%vty,p%precv(level)%base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -980,13 +940,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& - & mlprec_wrk(level)%vty,zone,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vty,zone,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%vty,zone,mlprec_wrk(level)%vy2l,& + & p%wrk(level)%vty,zone,p%wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -1014,7 +974,7 @@ contains end subroutine mld_z_inner_k_cycle - recursive subroutine mld_zinneritkcycle(p, mlprec_wrk, level, trans, work, innersolv) + recursive subroutine mld_zinneritkcycle(p, level, trans, work, innersolv) use psb_base_mod use mld_prec_mod use mld_z_inner_mod, mld_protect_name => mld_zmlprec_aply @@ -1024,7 +984,6 @@ contains !Input/Oputput variables type(mld_zprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans character(len=*), intent(in) :: innersolv @@ -1044,34 +1003,34 @@ contains call psb_geasb(rhs,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) call psb_geasb(w,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) call psb_geasb(v,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) call psb_geasb(v1,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) call psb_geasb(x,& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + & scratch=.true.,mold=p%wrk(level)%vx2l%v) !Assemble d(0) and d(1) call psb_geasb(d(0),& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) + & scratch=.true.,mold=p%wrk(level)%vy2l%v) call psb_geasb(d(1),& & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) + & scratch=.true.,mold=p%wrk(level)%vy2l%v) call x%zero() ! rhs=vx2l and w=rhs - call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,zzero,rhs,& + call psb_geaxpby(zone,p%wrk(level)%vx2l,zzero,rhs,& & p%precv(level)%base_desc,info) - call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,zzero,w,& + call psb_geaxpby(zone,p%wrk(level)%vx2l,zzero,w,& & p%precv(level)%base_desc,info) if (psb_errstatus_fatal()) then @@ -1085,12 +1044,12 @@ contains delta0 = psb_genrm2(w, p%precv(level)%base_desc, info) !Apply the preconditioner - call mlprec_wrk(level)%vy2l%zero() + call p%wrk(level)%vy2l%zero() idx=0 - call inner_ml_aply(level,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level,p,trans,work,info) - call psb_geaxpby(zone,mlprec_wrk(level)%vy2l,zzero,d(idx),p%precv(level)%base_desc,info) + call psb_geaxpby(zone,p%wrk(level)%vy2l,zzero,d(idx),p%precv(level)%base_desc,info) call psb_spmm(zone,p%precv(level)%base_a,d(idx),zzero,v,p%precv(level)%base_desc,info) if (info /= psb_success_) then @@ -1128,9 +1087,9 @@ contains idx=mod(iter,2) !Apply preconditioner - call psb_geaxpby(zone,w,zzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) - call inner_ml_aply(level,p,mlprec_wrk,trans,work,info) - call psb_geaxpby(zone,mlprec_wrk(level)%vy2l,zzero,d(idx),p%precv(level)%base_desc,info) + call psb_geaxpby(zone,w,zzero,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) + call inner_ml_aply(level,p,trans,work,info) + call psb_geaxpby(zone,p%wrk(level)%vy2l,zzero,d(idx),p%precv(level)%base_desc,info) !Sparse matrix vector product @@ -1165,7 +1124,7 @@ contains call psb_geaxpby(alpha,d(idx),zone,x,p%precv(level)%base_desc,info) endif - call psb_geaxpby(zone,x,zzero,mlprec_wrk(level)%vy2l,p%precv(level)%base_desc,info) + call psb_geaxpby(zone,x,zzero,p%wrk(level)%vy2l,p%precv(level)%base_desc,info) !Free vectors call psb_gefree(v, p%precv(level)%base_desc, info) call psb_gefree(v1, p%precv(level)%base_desc, info) @@ -1217,10 +1176,10 @@ subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level character(len=20) :: name character :: trans_ - type mld_mlprec_wrk_type + type mld_mlwrk_type complex(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) - end type mld_mlprec_wrk_type - type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) + end type mld_mlwrk_type + type(mld_mlwrk_type), allocatable, target :: mlwrk(:) name='mld_zmlprec_aply' info = psb_success_ @@ -1238,7 +1197,7 @@ subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) trans_ = psb_toupper(trans) nlev = size(p%precv) - allocate(mlprec_wrk(nlev),stat=info) + allocate(mlwrk(nlev),stat=info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 @@ -1246,13 +1205,13 @@ subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) level = 1 do level = 1, nlev - call psb_geasb(mlprec_wrk(level)%x2l,& + call psb_geasb(mlwrk(level)%x2l,& & p%precv(level)%base_desc,info) - call psb_geasb(mlprec_wrk(level)%y2l,& + call psb_geasb(mlwrk(level)%y2l,& & p%precv(level)%base_desc,info) - call psb_geasb(mlprec_wrk(level)%tx,& + call psb_geasb(mlwrk(level)%tx,& & p%precv(level)%base_desc,info) - call psb_geasb(mlprec_wrk(level)%ty,& + call psb_geasb(mlwrk(level)%ty,& & p%precv(level)%base_desc,info) if (psb_errstatus_fatal()) then nc2l = p%precv(level)%base_desc%get_local_cols() @@ -1263,10 +1222,10 @@ subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) end if end do - mlprec_wrk(level)%x2l(:) = x(:) - mlprec_wrk(level)%y2l(:) = zzero + mlwrk(level)%x2l(:) = x(:) + mlwrk(level)%y2l(:) = zzero - call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) + call inner_ml_aply(level,p,mlwrk,trans_,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1274,7 +1233,7 @@ subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) goto 9999 end if - call psb_geaxpby(alpha,mlprec_wrk(level)%y2l,beta,y,& + call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,& & p%precv(level)%base_desc,info) if (info /= psb_success_) then @@ -1315,14 +1274,14 @@ contains ! between level and level+1 are stored at level+1. ! ! - recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info) + recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info) implicit none ! Arguments integer(psb_ipk_) :: level type(mld_zprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) + type(mld_mlwrk_type), intent(inout), target :: mlwrk(:) character, intent(in) :: trans complex(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(out) :: info @@ -1370,15 +1329,15 @@ contains case(mld_add_ml_) - call mld_z_inner_add(p, mlprec_wrk, level, trans, work) + call mld_z_inner_add(p, mlwrk, level, trans, work) case(mld_mult_ml_, mld_vcycle_ml_, mld_wcycle_ml_) - call mld_z_inner_mult(p, mlprec_wrk, level, trans, work) + call mld_z_inner_mult(p, mlwrk, level, trans, work) ! !$ case(mld_kcycle_ml_, mld_kcyclesym_ml_) ! !$ -! !$ call mld_z_inner_k_cycle(p, mlprec_wrk, level, trans, work) +! !$ call mld_z_inner_k_cycle(p, mlwrk, level, trans, work) case default info = psb_err_from_subroutine_ai_ @@ -1397,7 +1356,7 @@ contains end subroutine inner_ml_aply - recursive subroutine mld_z_inner_add(p, mlprec_wrk, level, trans, work) + recursive subroutine mld_z_inner_add(p, mlwrk, level, trans, work) use psb_base_mod use mld_prec_mod @@ -1406,7 +1365,7 @@ contains !Input/Oputput variables type(mld_zprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + type(mld_mlwrk_type), target, intent(inout) :: mlwrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans complex(psb_dpk_),target :: work(:) @@ -1450,7 +1409,7 @@ contains sweeps = p%precv(level)%parms%sweeps_pre call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& + & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then @@ -1461,17 +1420,17 @@ contains if (level < nlev) then ! Apply the restriction - call psb_map_X2Y(zone,mlprec_wrk(level)%x2l,& - & zzero,mlprec_wrk(level+1)%x2l,& + call psb_map_X2Y(zone,mlwrk(level)%x2l,& + & zzero,mlwrk(level+1)%x2l,& & p%precv(level+1)%map,info,work=work) - mlprec_wrk(level+1)%y2l(:) = zzero + mlwrk(level+1)%y2l(:) = zzero if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') goto 9999 end if - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,mlwrk,trans,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error in recursive call') @@ -1481,8 +1440,8 @@ contains ! ! Apply the prolongator and add correction. ! - call psb_map_Y2X(zone,mlprec_wrk(level+1)%y2l,& - & zone,mlprec_wrk(level)%y2l,& + call psb_map_Y2X(zone,mlwrk(level+1)%y2l,& + & zone,mlwrk(level)%y2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1501,7 +1460,7 @@ contains end subroutine mld_z_inner_add - recursive subroutine mld_z_inner_mult(p, mlprec_wrk, level, trans, work) + recursive subroutine mld_z_inner_mult(p, mlwrk, level, trans, work) use psb_base_mod use mld_prec_mod @@ -1510,7 +1469,7 @@ contains !Input/Oputput variables type(mld_zprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + type(mld_mlwrk_type), target, intent(inout) :: mlwrk(:) integer(psb_ipk_), intent(in) :: level character, intent(in) :: trans complex(psb_dpk_),target :: work(:) @@ -1567,13 +1526,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& + & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Y') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& - & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& + & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Y') end if @@ -1589,20 +1548,20 @@ contains ! Compute the residual and call recursively ! if (pre) then - call psb_geaxpby(zone,mlprec_wrk(level)%x2l,& - & zzero,mlprec_wrk(level)%ty,& + call psb_geaxpby(zone,mlwrk(level)%x2l,& + & zzero,mlwrk(level)%ty,& & p%precv(level)%base_desc,info) if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& - & mlprec_wrk(level)%y2l,zone,mlprec_wrk(level)%ty,& + & mlwrk(level)%y2l,zone,mlwrk(level)%ty,& & p%precv(level)%base_desc,info,work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') goto 9999 end if - call psb_map_X2Y(zone,mlprec_wrk(level)%ty,& - & zzero,mlprec_wrk(level+1)%x2l,& + call psb_map_X2Y(zone,mlwrk(level)%ty,& + & zzero,mlwrk(level+1)%x2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1611,8 +1570,8 @@ contains end if else ! Shortcut: just transfer x2l. - call psb_map_X2Y(zone,mlprec_wrk(level)%x2l,& - & zzero,mlprec_wrk(level+1)%x2l,& + call psb_map_X2Y(zone,mlwrk(level)%x2l,& + & zzero,mlwrk(level+1)%x2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1621,14 +1580,14 @@ contains end if endif ! First guess is zero - mlprec_wrk(level+1)%y2l(:) = zzero + mlwrk(level+1)%y2l(:) = zzero - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + call inner_ml_aply(level+1,p,mlwrk,trans,work,info) if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then ! On second call will use output y2l as initial guess - if (info == psb_success_) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info) endif if (info /= psb_success_) then @@ -1641,8 +1600,8 @@ contains ! ! Apply the prolongator ! - call psb_map_Y2X(zone,mlprec_wrk(level+1)%y2l,& - & zone,mlprec_wrk(level)%y2l,& + call psb_map_Y2X(zone,mlwrk(level+1)%y2l,& + & zone,mlwrk(level)%y2l,& & p%precv(level+1)%map,info,work=work) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1654,11 +1613,11 @@ contains ! Compute the residual ! if (post) then - call psb_geaxpby(zone,mlprec_wrk(level)%x2l,& - & zzero,mlprec_wrk(level)%tx,& + call psb_geaxpby(zone,mlwrk(level)%x2l,& + & zzero,mlwrk(level)%tx,& & p%precv(level)%base_desc,info) - call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& - & zone,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,& + call psb_spmm(-zone,p%precv(level)%base_a,mlwrk(level)%y2l,& + & zone,mlwrk(level)%tx,p%precv(level)%base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1671,13 +1630,13 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& - & mlprec_wrk(level)%tx,zone,mlprec_wrk(level)%y2l,& + & mlwrk(level)%tx,zone,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%tx,zone,mlprec_wrk(level)%y2l,& + & mlwrk(level)%tx,zone,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info,init='Z') end if @@ -1694,7 +1653,7 @@ contains sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& + & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) diff --git a/mlprec/mld_c_inner_mod.f90 b/mlprec/mld_c_inner_mod.f90 index 1fb051fb..cdf7297c 100644 --- a/mlprec/mld_c_inner_mod.f90 +++ b/mlprec/mld_c_inner_mod.f90 @@ -48,7 +48,8 @@ module mld_c_inner_mod 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_, & & psb_c_vect_type - use mld_c_prec_type, only : mld_cprec_type, mld_sml_parms, mld_c_onelev_type + use mld_c_prec_type, only : mld_cprec_type, mld_sml_parms, & + & mld_c_onelev_type, mld_cmlprec_wrk_type interface mld_mlprec_bld subroutine mld_cmlprec_bld(a,desc_a,prec,info, amold, vmold,imold) diff --git a/mlprec/mld_d_inner_mod.f90 b/mlprec/mld_d_inner_mod.f90 index 004427e1..c4ca43dd 100644 --- a/mlprec/mld_d_inner_mod.f90 +++ b/mlprec/mld_d_inner_mod.f90 @@ -48,7 +48,8 @@ module mld_d_inner_mod 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_, & & psb_d_vect_type - use mld_d_prec_type, only : mld_dprec_type, mld_dml_parms, mld_d_onelev_type + use mld_d_prec_type, only : mld_dprec_type, mld_dml_parms, & + & mld_d_onelev_type, mld_dmlprec_wrk_type interface mld_mlprec_bld subroutine mld_dmlprec_bld(a,desc_a,prec,info, amold, vmold,imold) diff --git a/mlprec/mld_s_inner_mod.f90 b/mlprec/mld_s_inner_mod.f90 index 9752a3aa..23a13e43 100644 --- a/mlprec/mld_s_inner_mod.f90 +++ b/mlprec/mld_s_inner_mod.f90 @@ -48,7 +48,8 @@ module mld_s_inner_mod 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_, & & psb_s_vect_type - use mld_s_prec_type, only : mld_sprec_type, mld_sml_parms, mld_s_onelev_type + use mld_s_prec_type, only : mld_sprec_type, mld_sml_parms, & + & mld_s_onelev_type, mld_smlprec_wrk_type interface mld_mlprec_bld subroutine mld_smlprec_bld(a,desc_a,prec,info, amold, vmold,imold) diff --git a/mlprec/mld_z_inner_mod.f90 b/mlprec/mld_z_inner_mod.f90 index 22a45f66..21948573 100644 --- a/mlprec/mld_z_inner_mod.f90 +++ b/mlprec/mld_z_inner_mod.f90 @@ -48,7 +48,8 @@ module mld_z_inner_mod 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_, & & psb_z_vect_type - use mld_z_prec_type, only : mld_zprec_type, mld_dml_parms, mld_z_onelev_type + use mld_z_prec_type, only : mld_zprec_type, mld_dml_parms, & + & mld_z_onelev_type, mld_zmlprec_wrk_type interface mld_mlprec_bld subroutine mld_zmlprec_bld(a,desc_a,prec,info, amold, vmold,imold) From f982986a1c2e958bd88b9bd88ef705746480ed11 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 7 Dec 2017 17:45:47 +0000 Subject: [PATCH 05/16] Initial methods to keep track of work vectors. --- mlprec/mld_c_as_smoother.f90 | 14 +++++++- mlprec/mld_c_base_smoother_mod.f90 | 17 +++++++++- mlprec/mld_c_base_solver_mod.f90 | 15 +++++++-- mlprec/mld_c_gs_solver.f90 | 10 +++++- mlprec/mld_c_ilu_solver.f90 | 11 ++++++- mlprec/mld_c_jac_smoother.f90 | 14 +++++++- mlprec/mld_c_onelev_mod.f90 | 53 ++++++++++++++++++++++++++++-- mlprec/mld_c_prec_type.f90 | 6 ---- mlprec/mld_d_as_smoother.f90 | 14 +++++++- mlprec/mld_d_base_smoother_mod.f90 | 17 +++++++++- mlprec/mld_d_base_solver_mod.f90 | 15 +++++++-- mlprec/mld_d_gs_solver.f90 | 10 +++++- mlprec/mld_d_ilu_solver.f90 | 11 ++++++- mlprec/mld_d_jac_smoother.f90 | 14 +++++++- mlprec/mld_d_onelev_mod.f90 | 53 ++++++++++++++++++++++++++++-- mlprec/mld_d_prec_type.f90 | 6 ---- mlprec/mld_s_as_smoother.f90 | 14 +++++++- mlprec/mld_s_base_smoother_mod.f90 | 17 +++++++++- mlprec/mld_s_base_solver_mod.f90 | 15 +++++++-- mlprec/mld_s_gs_solver.f90 | 10 +++++- mlprec/mld_s_ilu_solver.f90 | 11 ++++++- mlprec/mld_s_jac_smoother.f90 | 14 +++++++- mlprec/mld_s_onelev_mod.f90 | 53 ++++++++++++++++++++++++++++-- mlprec/mld_s_prec_type.f90 | 6 ---- mlprec/mld_z_as_smoother.f90 | 14 +++++++- mlprec/mld_z_base_smoother_mod.f90 | 17 +++++++++- mlprec/mld_z_base_solver_mod.f90 | 15 +++++++-- mlprec/mld_z_gs_solver.f90 | 10 +++++- mlprec/mld_z_ilu_solver.f90 | 11 ++++++- mlprec/mld_z_jac_smoother.f90 | 14 +++++++- mlprec/mld_z_onelev_mod.f90 | 53 ++++++++++++++++++++++++++++-- mlprec/mld_z_prec_type.f90 | 6 ---- 32 files changed, 496 insertions(+), 64 deletions(-) diff --git a/mlprec/mld_c_as_smoother.f90 b/mlprec/mld_c_as_smoother.f90 index 8f19d162..c7d5ccd6 100644 --- a/mlprec/mld_c_as_smoother.f90 +++ b/mlprec/mld_c_as_smoother.f90 @@ -91,6 +91,7 @@ module mld_c_as_smoother procedure, pass(sm) :: sizeof => c_as_smoother_sizeof procedure, pass(sm) :: default => c_as_smoother_default procedure, pass(sm) :: get_nzeros => c_as_smoother_get_nzeros + procedure, pass(sm) :: get_wrksz => c_as_smoother_get_wrksize procedure, nopass :: get_fmt => c_as_smoother_get_fmt procedure, nopass :: get_id => c_as_smoother_get_id end type mld_c_as_smoother_type @@ -98,7 +99,8 @@ module mld_c_as_smoother private :: c_as_smoother_descr, c_as_smoother_sizeof, & & c_as_smoother_default, c_as_smoother_get_nzeros, & - & c_as_smoother_get_fmt, c_as_smoother_get_id + & c_as_smoother_get_fmt, c_as_smoother_get_id, & + & c_as_smoother_get_wrksize character(len=6), parameter, private :: & & restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/) @@ -458,6 +460,16 @@ contains end subroutine c_as_smoother_descr + function c_as_smoother_get_wrksize(sm) result(val) + implicit none + class(mld_c_as_smoother_type), intent(inout) :: sm + integer(psb_ipk_) :: val + + val = 3 + if (allocated(sm%sv)) val = val + sm%sv%get_wrksz() + + end function c_as_smoother_get_wrksize + function c_as_smoother_get_fmt() result(val) implicit none character(len=32) :: val diff --git a/mlprec/mld_c_base_smoother_mod.f90 b/mlprec/mld_c_base_smoother_mod.f90 index c442d048..9c542cbd 100644 --- a/mlprec/mld_c_base_smoother_mod.f90 +++ b/mlprec/mld_c_base_smoother_mod.f90 @@ -92,6 +92,10 @@ module mld_c_base_smoother_mod ! check - Sanity checks. ! sizeof - Total memory occupation in bytes ! get_nzeros - Number of nonzeros + ! stringval - convert string to val for internal parms + ! get_fmt - short string descriptor + ! get_id - numeric id descriptro + ! get_wrksz - How many workspace vector does apply_vect need ! ! ! @@ -119,6 +123,7 @@ module mld_c_base_smoother_mod procedure, pass(sm) :: descr => mld_c_base_smoother_descr procedure, pass(sm) :: sizeof => c_base_smoother_sizeof procedure, pass(sm) :: get_nzeros => c_base_smoother_get_nzeros + procedure, pass(sm) :: get_wrksz => c_base_smoother_get_wrksize procedure, nopass :: stringval => mld_stringval procedure, nopass :: get_fmt => c_base_smoother_get_fmt procedure, nopass :: get_id => c_base_smoother_get_id @@ -127,7 +132,7 @@ module mld_c_base_smoother_mod private :: c_base_smoother_sizeof, c_base_smoother_get_fmt, & & c_base_smoother_default, c_base_smoother_get_nzeros, & - & c_base_smoother_get_id + & c_base_smoother_get_id, c_base_smoother_get_wrksize @@ -387,6 +392,16 @@ contains return end subroutine c_base_smoother_default + function c_base_smoother_get_wrksize(sm) result(val) + implicit none + class(mld_c_base_smoother_type), intent(inout) :: sm + integer(psb_ipk_) :: val + + val = 0 + if (allocated(sm%sv)) val = val + sm%sv%get_wrksz() + + end function c_base_smoother_get_wrksize + function c_base_smoother_get_fmt() result(val) implicit none character(len=32) :: val diff --git a/mlprec/mld_c_base_solver_mod.f90 b/mlprec/mld_c_base_solver_mod.f90 index 6ebf1255..299f547c 100644 --- a/mlprec/mld_c_base_solver_mod.f90 +++ b/mlprec/mld_c_base_solver_mod.f90 @@ -78,7 +78,10 @@ module mld_c_base_solver_mod ! check - Sanity checks. ! sizeof - Total memory occupation in bytes ! get_nzeros - Number of nonzeros - ! + ! stringval - convert string to val for internal parms + ! get_fmt - short string descriptor + ! get_id - numeric id descriptro + ! get_wrksz - How many workspace vector does apply_vect need ! ! @@ -104,6 +107,7 @@ module mld_c_base_solver_mod procedure, pass(sv) :: descr => mld_c_base_solver_descr procedure, pass(sv) :: sizeof => c_base_solver_sizeof procedure, pass(sv) :: get_nzeros => c_base_solver_get_nzeros + procedure, nopass :: get_wrksz => c_base_solver_get_wrksize procedure, nopass :: stringval => mld_stringval procedure, nopass :: get_fmt => c_base_solver_get_fmt procedure, nopass :: get_id => c_base_solver_get_id @@ -112,7 +116,8 @@ module mld_c_base_solver_mod private :: c_base_solver_sizeof, c_base_solver_default,& & c_base_solver_get_nzeros, c_base_solver_get_fmt, & - & c_base_solver_is_iterative, c_base_solver_get_id + & c_base_solver_is_iterative, c_base_solver_get_id, & + & c_base_solver_get_wrksize interface @@ -411,5 +416,11 @@ contains val = mld_f_none_ end function c_base_solver_get_id + function c_base_solver_get_wrksize() result(val) + implicit none + integer(psb_ipk_) :: val + + val = 0 + end function c_base_solver_get_wrksize end module mld_c_base_solver_mod diff --git a/mlprec/mld_c_gs_solver.f90 b/mlprec/mld_c_gs_solver.f90 index 1e356bb8..f8a8d3bb 100644 --- a/mlprec/mld_c_gs_solver.f90 +++ b/mlprec/mld_c_gs_solver.f90 @@ -77,6 +77,7 @@ module mld_c_gs_solver procedure, pass(sv) :: default => c_gs_solver_default procedure, pass(sv) :: sizeof => c_gs_solver_sizeof procedure, pass(sv) :: get_nzeros => c_gs_solver_get_nzeros + procedure, nopass :: get_wrksz => c_gs_solver_get_wrksize procedure, nopass :: get_fmt => c_gs_solver_get_fmt procedure, nopass :: get_id => c_gs_solver_get_id procedure, nopass :: is_iterative => c_gs_solver_is_iterative @@ -102,7 +103,7 @@ module mld_c_gs_solver & c_gs_solver_get_fmt, c_gs_solver_check,& & c_gs_solver_is_iterative, & & c_bwgs_solver_get_fmt, c_bwgs_solver_descr, & - & c_gs_solver_get_id, c_bwgs_solver_get_id + & c_gs_solver_get_id, c_bwgs_solver_get_id, c_gs_solver_get_wrksize interface subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& @@ -642,4 +643,11 @@ contains val = mld_bwgs_ end function c_bwgs_solver_get_id + function c_gs_solver_get_wrksize() result(val) + implicit none + integer(psb_ipk_) :: val + + val = 2 + end function c_gs_solver_get_wrksize + end module mld_c_gs_solver diff --git a/mlprec/mld_c_ilu_solver.f90 b/mlprec/mld_c_ilu_solver.f90 index 0e327750..f7a63066 100644 --- a/mlprec/mld_c_ilu_solver.f90 +++ b/mlprec/mld_c_ilu_solver.f90 @@ -85,6 +85,7 @@ module mld_c_ilu_solver procedure, pass(sv) :: default => c_ilu_solver_default procedure, pass(sv) :: sizeof => c_ilu_solver_sizeof procedure, pass(sv) :: get_nzeros => c_ilu_solver_get_nzeros + procedure, nopass :: get_wrksz => c_ilu_solver_get_wrksize procedure, nopass :: get_fmt => c_ilu_solver_get_fmt procedure, nopass :: get_id => c_ilu_solver_get_id end type mld_c_ilu_solver_type @@ -96,7 +97,8 @@ module mld_c_ilu_solver & c_ilu_solver_descr, c_ilu_solver_sizeof, & & c_ilu_solver_default, c_ilu_solver_dmp, & & c_ilu_solver_apply_vect, c_ilu_solver_get_nzeros, & - & c_ilu_solver_get_fmt, c_ilu_solver_check, c_ilu_solver_get_id + & c_ilu_solver_get_fmt, c_ilu_solver_check, & + & c_ilu_solver_get_id, c_ilu_solver_get_wrksize interface @@ -554,5 +556,12 @@ contains val = mld_ilu_n_ end function c_ilu_solver_get_id + + function c_ilu_solver_get_wrksize() result(val) + implicit none + integer(psb_ipk_) :: val + + val = 2 + end function c_ilu_solver_get_wrksize end module mld_c_ilu_solver diff --git a/mlprec/mld_c_jac_smoother.f90 b/mlprec/mld_c_jac_smoother.f90 index 50bf6f19..3b464b6d 100644 --- a/mlprec/mld_c_jac_smoother.f90 +++ b/mlprec/mld_c_jac_smoother.f90 @@ -71,6 +71,7 @@ module mld_c_jac_smoother procedure, pass(sm) :: descr => mld_c_jac_smoother_descr procedure, pass(sm) :: sizeof => c_jac_smoother_sizeof procedure, pass(sm) :: get_nzeros => c_jac_smoother_get_nzeros + procedure, pass(sm) :: get_wrksz => c_jac_smoother_get_wrksize procedure, nopass :: get_fmt => c_jac_smoother_get_fmt procedure, nopass :: get_id => c_jac_smoother_get_id end type mld_c_jac_smoother_type @@ -78,7 +79,8 @@ module mld_c_jac_smoother private :: c_jac_smoother_free, c_jac_smoother_descr, & & c_jac_smoother_sizeof, c_jac_smoother_get_nzeros, & - & c_jac_smoother_get_fmt, c_jac_smoother_get_id + & c_jac_smoother_get_fmt, c_jac_smoother_get_id, & + & c_jac_smoother_get_wrksize interface @@ -253,6 +255,16 @@ contains return end function c_jac_smoother_get_nzeros + function c_jac_smoother_get_wrksize(sm) result(val) + implicit none + class(mld_c_jac_smoother_type), intent(inout) :: sm + integer(psb_ipk_) :: val + + val = 2 + if (allocated(sm%sv)) val = val + sm%sv%get_wrksz() + + end function c_jac_smoother_get_wrksize + function c_jac_smoother_get_fmt() result(val) implicit none character(len=32) :: val diff --git a/mlprec/mld_c_onelev_mod.f90 b/mlprec/mld_c_onelev_mod.f90 index 01068337..f19ce582 100644 --- a/mlprec/mld_c_onelev_mod.f90 +++ b/mlprec/mld_c_onelev_mod.f90 @@ -117,11 +117,20 @@ module mld_c_onelev_mod ! check - Sanity checks. ! sizeof - Total memory occupation in bytes ! get_nzeros - Number of nonzeros + ! get_wrksz - How many workspace vector does apply_vect need ! - ! + ! + type mld_cmlprec_wrk_type + complex(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + type(psb_c_vect_type) :: vtx, vty, vx2l, vy2l + integer(psb_ipk_) :: wvsz = 0 + type(psb_c_vect_type), allocatable :: wv(:) + end type mld_cmlprec_wrk_type + type mld_c_onelev_type class(mld_c_base_smoother_type), allocatable :: sm, sm2a class(mld_c_base_smoother_type), pointer :: sm2 => null() + type(mld_cmlprec_wrk_type) :: wrk type(mld_sml_parms) :: parms type(psb_cspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -153,6 +162,7 @@ module mld_c_onelev_mod & cseti, csetr, csetc, setsm, setsv procedure, pass(lv) :: sizeof => c_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => c_base_onelev_get_nzeros + procedure, pass(lv) :: get_wrksz => c_base_onelev_get_wrksize procedure, nopass :: stringval => mld_stringval procedure, pass(lv) :: move_alloc => c_base_onelev_move_alloc end type mld_c_onelev_type @@ -164,7 +174,8 @@ module mld_c_onelev_mod private :: c_base_onelev_default, c_base_onelev_sizeof, & & c_base_onelev_nullify, c_base_onelev_get_nzeros, & - & c_base_onelev_clone, c_base_onelev_move_alloc + & c_base_onelev_clone, c_base_onelev_move_alloc, & + & c_base_onelev_get_wrksize @@ -498,7 +509,6 @@ contains end subroutine c_base_onelev_clone - subroutine c_base_onelev_move_alloc(lv, b,info) use psb_base_mod implicit none @@ -527,4 +537,41 @@ contains end subroutine c_base_onelev_move_alloc + + function c_base_onelev_get_wrksize(lv) result(val) + implicit none + class(mld_c_base_onelev_type), intent(inout) :: lv + integer(psb_ipk_) :: val + + val = 0 + ! SM and SM2A can share work vectors + if (allocated(lv%sm)) val = val + sm%get_wrksz() + if (allocated(lv%sm2a)) val = max(val,sm2a%get_wrksz()) + ! + ! Now for the ML application itself + ! + ! We have VTX/VTY/VX2L/VY2L + ! + val = val + 4 + ! + ! plus some additions for specific ML/cycles + ! + select case(lv%parms%ml_cycle) + case(mld_add_ml_,mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_) + ! We're good + + case(mld_kcycle_ml_, mld_kcyclesym_ml_) + ! + ! We need 7 in inneritkcycle, but we can reuse vtx + ! + val = val + 6 + + case default + ! Need a better error signaling ? + val = -1 + end select + + end function c_base_onelev_get_wrksize + + end module mld_c_onelev_mod diff --git a/mlprec/mld_c_prec_type.f90 b/mlprec/mld_c_prec_type.f90 index 83243309..092fe9ad 100644 --- a/mlprec/mld_c_prec_type.f90 +++ b/mlprec/mld_c_prec_type.f90 @@ -80,12 +80,6 @@ module mld_c_prec_type ! order, with level 0 being the id of the coarsest level. ! ! - - 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 diff --git a/mlprec/mld_d_as_smoother.f90 b/mlprec/mld_d_as_smoother.f90 index 2f5b6633..18d2313c 100644 --- a/mlprec/mld_d_as_smoother.f90 +++ b/mlprec/mld_d_as_smoother.f90 @@ -91,6 +91,7 @@ module mld_d_as_smoother procedure, pass(sm) :: sizeof => d_as_smoother_sizeof procedure, pass(sm) :: default => d_as_smoother_default procedure, pass(sm) :: get_nzeros => d_as_smoother_get_nzeros + procedure, pass(sm) :: get_wrksz => d_as_smoother_get_wrksize procedure, nopass :: get_fmt => d_as_smoother_get_fmt procedure, nopass :: get_id => d_as_smoother_get_id end type mld_d_as_smoother_type @@ -98,7 +99,8 @@ module mld_d_as_smoother private :: d_as_smoother_descr, d_as_smoother_sizeof, & & d_as_smoother_default, d_as_smoother_get_nzeros, & - & d_as_smoother_get_fmt, d_as_smoother_get_id + & d_as_smoother_get_fmt, d_as_smoother_get_id, & + & d_as_smoother_get_wrksize character(len=6), parameter, private :: & & restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/) @@ -458,6 +460,16 @@ contains end subroutine d_as_smoother_descr + function d_as_smoother_get_wrksize(sm) result(val) + implicit none + class(mld_d_as_smoother_type), intent(inout) :: sm + integer(psb_ipk_) :: val + + val = 3 + if (allocated(sm%sv)) val = val + sm%sv%get_wrksz() + + end function d_as_smoother_get_wrksize + function d_as_smoother_get_fmt() result(val) implicit none character(len=32) :: val diff --git a/mlprec/mld_d_base_smoother_mod.f90 b/mlprec/mld_d_base_smoother_mod.f90 index 36742af5..b42c96e6 100644 --- a/mlprec/mld_d_base_smoother_mod.f90 +++ b/mlprec/mld_d_base_smoother_mod.f90 @@ -92,6 +92,10 @@ module mld_d_base_smoother_mod ! check - Sanity checks. ! sizeof - Total memory occupation in bytes ! get_nzeros - Number of nonzeros + ! stringval - convert string to val for internal parms + ! get_fmt - short string descriptor + ! get_id - numeric id descriptro + ! get_wrksz - How many workspace vector does apply_vect need ! ! ! @@ -119,6 +123,7 @@ module mld_d_base_smoother_mod procedure, pass(sm) :: descr => mld_d_base_smoother_descr procedure, pass(sm) :: sizeof => d_base_smoother_sizeof procedure, pass(sm) :: get_nzeros => d_base_smoother_get_nzeros + procedure, pass(sm) :: get_wrksz => d_base_smoother_get_wrksize procedure, nopass :: stringval => mld_stringval procedure, nopass :: get_fmt => d_base_smoother_get_fmt procedure, nopass :: get_id => d_base_smoother_get_id @@ -127,7 +132,7 @@ module mld_d_base_smoother_mod private :: d_base_smoother_sizeof, d_base_smoother_get_fmt, & & d_base_smoother_default, d_base_smoother_get_nzeros, & - & d_base_smoother_get_id + & d_base_smoother_get_id, d_base_smoother_get_wrksize @@ -387,6 +392,16 @@ contains return end subroutine d_base_smoother_default + function d_base_smoother_get_wrksize(sm) result(val) + implicit none + class(mld_d_base_smoother_type), intent(inout) :: sm + integer(psb_ipk_) :: val + + val = 0 + if (allocated(sm%sv)) val = val + sm%sv%get_wrksz() + + end function d_base_smoother_get_wrksize + function d_base_smoother_get_fmt() result(val) implicit none character(len=32) :: val diff --git a/mlprec/mld_d_base_solver_mod.f90 b/mlprec/mld_d_base_solver_mod.f90 index 86a63d69..e3a0242c 100644 --- a/mlprec/mld_d_base_solver_mod.f90 +++ b/mlprec/mld_d_base_solver_mod.f90 @@ -78,7 +78,10 @@ module mld_d_base_solver_mod ! check - Sanity checks. ! sizeof - Total memory occupation in bytes ! get_nzeros - Number of nonzeros - ! + ! stringval - convert string to val for internal parms + ! get_fmt - short string descriptor + ! get_id - numeric id descriptro + ! get_wrksz - How many workspace vector does apply_vect need ! ! @@ -104,6 +107,7 @@ module mld_d_base_solver_mod procedure, pass(sv) :: descr => mld_d_base_solver_descr procedure, pass(sv) :: sizeof => d_base_solver_sizeof procedure, pass(sv) :: get_nzeros => d_base_solver_get_nzeros + procedure, nopass :: get_wrksz => d_base_solver_get_wrksize procedure, nopass :: stringval => mld_stringval procedure, nopass :: get_fmt => d_base_solver_get_fmt procedure, nopass :: get_id => d_base_solver_get_id @@ -112,7 +116,8 @@ module mld_d_base_solver_mod private :: d_base_solver_sizeof, d_base_solver_default,& & d_base_solver_get_nzeros, d_base_solver_get_fmt, & - & d_base_solver_is_iterative, d_base_solver_get_id + & d_base_solver_is_iterative, d_base_solver_get_id, & + & d_base_solver_get_wrksize interface @@ -411,5 +416,11 @@ contains val = mld_f_none_ end function d_base_solver_get_id + function d_base_solver_get_wrksize() result(val) + implicit none + integer(psb_ipk_) :: val + + val = 0 + end function d_base_solver_get_wrksize end module mld_d_base_solver_mod diff --git a/mlprec/mld_d_gs_solver.f90 b/mlprec/mld_d_gs_solver.f90 index 98d907ac..2c53ef10 100644 --- a/mlprec/mld_d_gs_solver.f90 +++ b/mlprec/mld_d_gs_solver.f90 @@ -77,6 +77,7 @@ module mld_d_gs_solver procedure, pass(sv) :: default => d_gs_solver_default procedure, pass(sv) :: sizeof => d_gs_solver_sizeof procedure, pass(sv) :: get_nzeros => d_gs_solver_get_nzeros + procedure, nopass :: get_wrksz => d_gs_solver_get_wrksize procedure, nopass :: get_fmt => d_gs_solver_get_fmt procedure, nopass :: get_id => d_gs_solver_get_id procedure, nopass :: is_iterative => d_gs_solver_is_iterative @@ -102,7 +103,7 @@ module mld_d_gs_solver & d_gs_solver_get_fmt, d_gs_solver_check,& & d_gs_solver_is_iterative, & & d_bwgs_solver_get_fmt, d_bwgs_solver_descr, & - & d_gs_solver_get_id, d_bwgs_solver_get_id + & d_gs_solver_get_id, d_bwgs_solver_get_id, d_gs_solver_get_wrksize interface subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& @@ -642,4 +643,11 @@ contains val = mld_bwgs_ end function d_bwgs_solver_get_id + function d_gs_solver_get_wrksize() result(val) + implicit none + integer(psb_ipk_) :: val + + val = 2 + end function d_gs_solver_get_wrksize + end module mld_d_gs_solver diff --git a/mlprec/mld_d_ilu_solver.f90 b/mlprec/mld_d_ilu_solver.f90 index ad894962..6fff1dd9 100644 --- a/mlprec/mld_d_ilu_solver.f90 +++ b/mlprec/mld_d_ilu_solver.f90 @@ -85,6 +85,7 @@ module mld_d_ilu_solver procedure, pass(sv) :: default => d_ilu_solver_default procedure, pass(sv) :: sizeof => d_ilu_solver_sizeof procedure, pass(sv) :: get_nzeros => d_ilu_solver_get_nzeros + procedure, nopass :: get_wrksz => d_ilu_solver_get_wrksize procedure, nopass :: get_fmt => d_ilu_solver_get_fmt procedure, nopass :: get_id => d_ilu_solver_get_id end type mld_d_ilu_solver_type @@ -96,7 +97,8 @@ module mld_d_ilu_solver & d_ilu_solver_descr, d_ilu_solver_sizeof, & & d_ilu_solver_default, d_ilu_solver_dmp, & & d_ilu_solver_apply_vect, d_ilu_solver_get_nzeros, & - & d_ilu_solver_get_fmt, d_ilu_solver_check, d_ilu_solver_get_id + & d_ilu_solver_get_fmt, d_ilu_solver_check, & + & d_ilu_solver_get_id, d_ilu_solver_get_wrksize interface @@ -554,5 +556,12 @@ contains val = mld_ilu_n_ end function d_ilu_solver_get_id + + function d_ilu_solver_get_wrksize() result(val) + implicit none + integer(psb_ipk_) :: val + + val = 2 + end function d_ilu_solver_get_wrksize end module mld_d_ilu_solver diff --git a/mlprec/mld_d_jac_smoother.f90 b/mlprec/mld_d_jac_smoother.f90 index db3010b8..ef03d431 100644 --- a/mlprec/mld_d_jac_smoother.f90 +++ b/mlprec/mld_d_jac_smoother.f90 @@ -71,6 +71,7 @@ module mld_d_jac_smoother procedure, pass(sm) :: descr => mld_d_jac_smoother_descr procedure, pass(sm) :: sizeof => d_jac_smoother_sizeof procedure, pass(sm) :: get_nzeros => d_jac_smoother_get_nzeros + procedure, pass(sm) :: get_wrksz => d_jac_smoother_get_wrksize procedure, nopass :: get_fmt => d_jac_smoother_get_fmt procedure, nopass :: get_id => d_jac_smoother_get_id end type mld_d_jac_smoother_type @@ -78,7 +79,8 @@ module mld_d_jac_smoother private :: d_jac_smoother_free, d_jac_smoother_descr, & & d_jac_smoother_sizeof, d_jac_smoother_get_nzeros, & - & d_jac_smoother_get_fmt, d_jac_smoother_get_id + & d_jac_smoother_get_fmt, d_jac_smoother_get_id, & + & d_jac_smoother_get_wrksize interface @@ -253,6 +255,16 @@ contains return end function d_jac_smoother_get_nzeros + function d_jac_smoother_get_wrksize(sm) result(val) + implicit none + class(mld_d_jac_smoother_type), intent(inout) :: sm + integer(psb_ipk_) :: val + + val = 2 + if (allocated(sm%sv)) val = val + sm%sv%get_wrksz() + + end function d_jac_smoother_get_wrksize + function d_jac_smoother_get_fmt() result(val) implicit none character(len=32) :: val diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index cd656242..23c35311 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -117,11 +117,20 @@ module mld_d_onelev_mod ! check - Sanity checks. ! sizeof - Total memory occupation in bytes ! get_nzeros - Number of nonzeros + ! get_wrksz - How many workspace vector does apply_vect need ! - ! + ! + type mld_dmlprec_wrk_type + real(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + type(psb_d_vect_type) :: vtx, vty, vx2l, vy2l + integer(psb_ipk_) :: wvsz = 0 + type(psb_d_vect_type), allocatable :: wv(:) + end type mld_dmlprec_wrk_type + type mld_d_onelev_type class(mld_d_base_smoother_type), allocatable :: sm, sm2a class(mld_d_base_smoother_type), pointer :: sm2 => null() + type(mld_dmlprec_wrk_type) :: wrk type(mld_dml_parms) :: parms type(psb_dspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -153,6 +162,7 @@ module mld_d_onelev_mod & cseti, csetr, csetc, setsm, setsv procedure, pass(lv) :: sizeof => d_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros + procedure, pass(lv) :: get_wrksz => d_base_onelev_get_wrksize procedure, nopass :: stringval => mld_stringval procedure, pass(lv) :: move_alloc => d_base_onelev_move_alloc end type mld_d_onelev_type @@ -164,7 +174,8 @@ module mld_d_onelev_mod private :: d_base_onelev_default, d_base_onelev_sizeof, & & d_base_onelev_nullify, d_base_onelev_get_nzeros, & - & d_base_onelev_clone, d_base_onelev_move_alloc + & d_base_onelev_clone, d_base_onelev_move_alloc, & + & d_base_onelev_get_wrksize @@ -498,7 +509,6 @@ contains end subroutine d_base_onelev_clone - subroutine d_base_onelev_move_alloc(lv, b,info) use psb_base_mod implicit none @@ -527,4 +537,41 @@ contains end subroutine d_base_onelev_move_alloc + + function d_base_onelev_get_wrksize(lv) result(val) + implicit none + class(mld_d_base_onelev_type), intent(inout) :: lv + integer(psb_ipk_) :: val + + val = 0 + ! SM and SM2A can share work vectors + if (allocated(lv%sm)) val = val + sm%get_wrksz() + if (allocated(lv%sm2a)) val = max(val,sm2a%get_wrksz()) + ! + ! Now for the ML application itself + ! + ! We have VTX/VTY/VX2L/VY2L + ! + val = val + 4 + ! + ! plus some additions for specific ML/cycles + ! + select case(lv%parms%ml_cycle) + case(mld_add_ml_,mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_) + ! We're good + + case(mld_kcycle_ml_, mld_kcyclesym_ml_) + ! + ! We need 7 in inneritkcycle, but we can reuse vtx + ! + val = val + 6 + + case default + ! Need a better error signaling ? + val = -1 + end select + + end function d_base_onelev_get_wrksize + + end module mld_d_onelev_mod diff --git a/mlprec/mld_d_prec_type.f90 b/mlprec/mld_d_prec_type.f90 index 64b74187..7cb2ff75 100644 --- a/mlprec/mld_d_prec_type.f90 +++ b/mlprec/mld_d_prec_type.f90 @@ -80,12 +80,6 @@ module mld_d_prec_type ! order, with level 0 being the id of the coarsest level. ! ! - - 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 diff --git a/mlprec/mld_s_as_smoother.f90 b/mlprec/mld_s_as_smoother.f90 index 437af7d0..e800c279 100644 --- a/mlprec/mld_s_as_smoother.f90 +++ b/mlprec/mld_s_as_smoother.f90 @@ -91,6 +91,7 @@ module mld_s_as_smoother procedure, pass(sm) :: sizeof => s_as_smoother_sizeof procedure, pass(sm) :: default => s_as_smoother_default procedure, pass(sm) :: get_nzeros => s_as_smoother_get_nzeros + procedure, pass(sm) :: get_wrksz => s_as_smoother_get_wrksize procedure, nopass :: get_fmt => s_as_smoother_get_fmt procedure, nopass :: get_id => s_as_smoother_get_id end type mld_s_as_smoother_type @@ -98,7 +99,8 @@ module mld_s_as_smoother private :: s_as_smoother_descr, s_as_smoother_sizeof, & & s_as_smoother_default, s_as_smoother_get_nzeros, & - & s_as_smoother_get_fmt, s_as_smoother_get_id + & s_as_smoother_get_fmt, s_as_smoother_get_id, & + & s_as_smoother_get_wrksize character(len=6), parameter, private :: & & restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/) @@ -458,6 +460,16 @@ contains end subroutine s_as_smoother_descr + function s_as_smoother_get_wrksize(sm) result(val) + implicit none + class(mld_s_as_smoother_type), intent(inout) :: sm + integer(psb_ipk_) :: val + + val = 3 + if (allocated(sm%sv)) val = val + sm%sv%get_wrksz() + + end function s_as_smoother_get_wrksize + function s_as_smoother_get_fmt() result(val) implicit none character(len=32) :: val diff --git a/mlprec/mld_s_base_smoother_mod.f90 b/mlprec/mld_s_base_smoother_mod.f90 index b8aa11e8..b5cb6020 100644 --- a/mlprec/mld_s_base_smoother_mod.f90 +++ b/mlprec/mld_s_base_smoother_mod.f90 @@ -92,6 +92,10 @@ module mld_s_base_smoother_mod ! check - Sanity checks. ! sizeof - Total memory occupation in bytes ! get_nzeros - Number of nonzeros + ! stringval - convert string to val for internal parms + ! get_fmt - short string descriptor + ! get_id - numeric id descriptro + ! get_wrksz - How many workspace vector does apply_vect need ! ! ! @@ -119,6 +123,7 @@ module mld_s_base_smoother_mod procedure, pass(sm) :: descr => mld_s_base_smoother_descr procedure, pass(sm) :: sizeof => s_base_smoother_sizeof procedure, pass(sm) :: get_nzeros => s_base_smoother_get_nzeros + procedure, pass(sm) :: get_wrksz => s_base_smoother_get_wrksize procedure, nopass :: stringval => mld_stringval procedure, nopass :: get_fmt => s_base_smoother_get_fmt procedure, nopass :: get_id => s_base_smoother_get_id @@ -127,7 +132,7 @@ module mld_s_base_smoother_mod private :: s_base_smoother_sizeof, s_base_smoother_get_fmt, & & s_base_smoother_default, s_base_smoother_get_nzeros, & - & s_base_smoother_get_id + & s_base_smoother_get_id, s_base_smoother_get_wrksize @@ -387,6 +392,16 @@ contains return end subroutine s_base_smoother_default + function s_base_smoother_get_wrksize(sm) result(val) + implicit none + class(mld_s_base_smoother_type), intent(inout) :: sm + integer(psb_ipk_) :: val + + val = 0 + if (allocated(sm%sv)) val = val + sm%sv%get_wrksz() + + end function s_base_smoother_get_wrksize + function s_base_smoother_get_fmt() result(val) implicit none character(len=32) :: val diff --git a/mlprec/mld_s_base_solver_mod.f90 b/mlprec/mld_s_base_solver_mod.f90 index 3feb4fc1..ebec407f 100644 --- a/mlprec/mld_s_base_solver_mod.f90 +++ b/mlprec/mld_s_base_solver_mod.f90 @@ -78,7 +78,10 @@ module mld_s_base_solver_mod ! check - Sanity checks. ! sizeof - Total memory occupation in bytes ! get_nzeros - Number of nonzeros - ! + ! stringval - convert string to val for internal parms + ! get_fmt - short string descriptor + ! get_id - numeric id descriptro + ! get_wrksz - How many workspace vector does apply_vect need ! ! @@ -104,6 +107,7 @@ module mld_s_base_solver_mod procedure, pass(sv) :: descr => mld_s_base_solver_descr procedure, pass(sv) :: sizeof => s_base_solver_sizeof procedure, pass(sv) :: get_nzeros => s_base_solver_get_nzeros + procedure, nopass :: get_wrksz => s_base_solver_get_wrksize procedure, nopass :: stringval => mld_stringval procedure, nopass :: get_fmt => s_base_solver_get_fmt procedure, nopass :: get_id => s_base_solver_get_id @@ -112,7 +116,8 @@ module mld_s_base_solver_mod private :: s_base_solver_sizeof, s_base_solver_default,& & s_base_solver_get_nzeros, s_base_solver_get_fmt, & - & s_base_solver_is_iterative, s_base_solver_get_id + & s_base_solver_is_iterative, s_base_solver_get_id, & + & s_base_solver_get_wrksize interface @@ -411,5 +416,11 @@ contains val = mld_f_none_ end function s_base_solver_get_id + function s_base_solver_get_wrksize() result(val) + implicit none + integer(psb_ipk_) :: val + + val = 0 + end function s_base_solver_get_wrksize end module mld_s_base_solver_mod diff --git a/mlprec/mld_s_gs_solver.f90 b/mlprec/mld_s_gs_solver.f90 index da7dc29e..b3619ebf 100644 --- a/mlprec/mld_s_gs_solver.f90 +++ b/mlprec/mld_s_gs_solver.f90 @@ -77,6 +77,7 @@ module mld_s_gs_solver procedure, pass(sv) :: default => s_gs_solver_default procedure, pass(sv) :: sizeof => s_gs_solver_sizeof procedure, pass(sv) :: get_nzeros => s_gs_solver_get_nzeros + procedure, nopass :: get_wrksz => s_gs_solver_get_wrksize procedure, nopass :: get_fmt => s_gs_solver_get_fmt procedure, nopass :: get_id => s_gs_solver_get_id procedure, nopass :: is_iterative => s_gs_solver_is_iterative @@ -102,7 +103,7 @@ module mld_s_gs_solver & s_gs_solver_get_fmt, s_gs_solver_check,& & s_gs_solver_is_iterative, & & s_bwgs_solver_get_fmt, s_bwgs_solver_descr, & - & s_gs_solver_get_id, s_bwgs_solver_get_id + & s_gs_solver_get_id, s_bwgs_solver_get_id, s_gs_solver_get_wrksize interface subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& @@ -642,4 +643,11 @@ contains val = mld_bwgs_ end function s_bwgs_solver_get_id + function s_gs_solver_get_wrksize() result(val) + implicit none + integer(psb_ipk_) :: val + + val = 2 + end function s_gs_solver_get_wrksize + end module mld_s_gs_solver diff --git a/mlprec/mld_s_ilu_solver.f90 b/mlprec/mld_s_ilu_solver.f90 index 96128069..8c93fa8d 100644 --- a/mlprec/mld_s_ilu_solver.f90 +++ b/mlprec/mld_s_ilu_solver.f90 @@ -85,6 +85,7 @@ module mld_s_ilu_solver procedure, pass(sv) :: default => s_ilu_solver_default procedure, pass(sv) :: sizeof => s_ilu_solver_sizeof procedure, pass(sv) :: get_nzeros => s_ilu_solver_get_nzeros + procedure, nopass :: get_wrksz => s_ilu_solver_get_wrksize procedure, nopass :: get_fmt => s_ilu_solver_get_fmt procedure, nopass :: get_id => s_ilu_solver_get_id end type mld_s_ilu_solver_type @@ -96,7 +97,8 @@ module mld_s_ilu_solver & s_ilu_solver_descr, s_ilu_solver_sizeof, & & s_ilu_solver_default, s_ilu_solver_dmp, & & s_ilu_solver_apply_vect, s_ilu_solver_get_nzeros, & - & s_ilu_solver_get_fmt, s_ilu_solver_check, s_ilu_solver_get_id + & s_ilu_solver_get_fmt, s_ilu_solver_check, & + & s_ilu_solver_get_id, s_ilu_solver_get_wrksize interface @@ -554,5 +556,12 @@ contains val = mld_ilu_n_ end function s_ilu_solver_get_id + + function s_ilu_solver_get_wrksize() result(val) + implicit none + integer(psb_ipk_) :: val + + val = 2 + end function s_ilu_solver_get_wrksize end module mld_s_ilu_solver diff --git a/mlprec/mld_s_jac_smoother.f90 b/mlprec/mld_s_jac_smoother.f90 index ff8704bd..ccb7d896 100644 --- a/mlprec/mld_s_jac_smoother.f90 +++ b/mlprec/mld_s_jac_smoother.f90 @@ -71,6 +71,7 @@ module mld_s_jac_smoother procedure, pass(sm) :: descr => mld_s_jac_smoother_descr procedure, pass(sm) :: sizeof => s_jac_smoother_sizeof procedure, pass(sm) :: get_nzeros => s_jac_smoother_get_nzeros + procedure, pass(sm) :: get_wrksz => s_jac_smoother_get_wrksize procedure, nopass :: get_fmt => s_jac_smoother_get_fmt procedure, nopass :: get_id => s_jac_smoother_get_id end type mld_s_jac_smoother_type @@ -78,7 +79,8 @@ module mld_s_jac_smoother private :: s_jac_smoother_free, s_jac_smoother_descr, & & s_jac_smoother_sizeof, s_jac_smoother_get_nzeros, & - & s_jac_smoother_get_fmt, s_jac_smoother_get_id + & s_jac_smoother_get_fmt, s_jac_smoother_get_id, & + & s_jac_smoother_get_wrksize interface @@ -253,6 +255,16 @@ contains return end function s_jac_smoother_get_nzeros + function s_jac_smoother_get_wrksize(sm) result(val) + implicit none + class(mld_s_jac_smoother_type), intent(inout) :: sm + integer(psb_ipk_) :: val + + val = 2 + if (allocated(sm%sv)) val = val + sm%sv%get_wrksz() + + end function s_jac_smoother_get_wrksize + function s_jac_smoother_get_fmt() result(val) implicit none character(len=32) :: val diff --git a/mlprec/mld_s_onelev_mod.f90 b/mlprec/mld_s_onelev_mod.f90 index b5f630a0..df8b78b2 100644 --- a/mlprec/mld_s_onelev_mod.f90 +++ b/mlprec/mld_s_onelev_mod.f90 @@ -117,11 +117,20 @@ module mld_s_onelev_mod ! check - Sanity checks. ! sizeof - Total memory occupation in bytes ! get_nzeros - Number of nonzeros + ! get_wrksz - How many workspace vector does apply_vect need ! - ! + ! + type mld_smlprec_wrk_type + real(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + type(psb_s_vect_type) :: vtx, vty, vx2l, vy2l + integer(psb_ipk_) :: wvsz = 0 + type(psb_s_vect_type), allocatable :: wv(:) + end type mld_smlprec_wrk_type + type mld_s_onelev_type class(mld_s_base_smoother_type), allocatable :: sm, sm2a class(mld_s_base_smoother_type), pointer :: sm2 => null() + type(mld_smlprec_wrk_type) :: wrk type(mld_sml_parms) :: parms type(psb_sspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -153,6 +162,7 @@ module mld_s_onelev_mod & cseti, csetr, csetc, setsm, setsv procedure, pass(lv) :: sizeof => s_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => s_base_onelev_get_nzeros + procedure, pass(lv) :: get_wrksz => s_base_onelev_get_wrksize procedure, nopass :: stringval => mld_stringval procedure, pass(lv) :: move_alloc => s_base_onelev_move_alloc end type mld_s_onelev_type @@ -164,7 +174,8 @@ module mld_s_onelev_mod private :: s_base_onelev_default, s_base_onelev_sizeof, & & s_base_onelev_nullify, s_base_onelev_get_nzeros, & - & s_base_onelev_clone, s_base_onelev_move_alloc + & s_base_onelev_clone, s_base_onelev_move_alloc, & + & s_base_onelev_get_wrksize @@ -498,7 +509,6 @@ contains end subroutine s_base_onelev_clone - subroutine s_base_onelev_move_alloc(lv, b,info) use psb_base_mod implicit none @@ -527,4 +537,41 @@ contains end subroutine s_base_onelev_move_alloc + + function s_base_onelev_get_wrksize(lv) result(val) + implicit none + class(mld_s_base_onelev_type), intent(inout) :: lv + integer(psb_ipk_) :: val + + val = 0 + ! SM and SM2A can share work vectors + if (allocated(lv%sm)) val = val + sm%get_wrksz() + if (allocated(lv%sm2a)) val = max(val,sm2a%get_wrksz()) + ! + ! Now for the ML application itself + ! + ! We have VTX/VTY/VX2L/VY2L + ! + val = val + 4 + ! + ! plus some additions for specific ML/cycles + ! + select case(lv%parms%ml_cycle) + case(mld_add_ml_,mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_) + ! We're good + + case(mld_kcycle_ml_, mld_kcyclesym_ml_) + ! + ! We need 7 in inneritkcycle, but we can reuse vtx + ! + val = val + 6 + + case default + ! Need a better error signaling ? + val = -1 + end select + + end function s_base_onelev_get_wrksize + + end module mld_s_onelev_mod diff --git a/mlprec/mld_s_prec_type.f90 b/mlprec/mld_s_prec_type.f90 index 1cfd35c7..59145790 100644 --- a/mlprec/mld_s_prec_type.f90 +++ b/mlprec/mld_s_prec_type.f90 @@ -80,12 +80,6 @@ module mld_s_prec_type ! order, with level 0 being the id of the coarsest level. ! ! - - 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 diff --git a/mlprec/mld_z_as_smoother.f90 b/mlprec/mld_z_as_smoother.f90 index a7fba9eb..468026c3 100644 --- a/mlprec/mld_z_as_smoother.f90 +++ b/mlprec/mld_z_as_smoother.f90 @@ -91,6 +91,7 @@ module mld_z_as_smoother procedure, pass(sm) :: sizeof => z_as_smoother_sizeof procedure, pass(sm) :: default => z_as_smoother_default procedure, pass(sm) :: get_nzeros => z_as_smoother_get_nzeros + procedure, pass(sm) :: get_wrksz => z_as_smoother_get_wrksize procedure, nopass :: get_fmt => z_as_smoother_get_fmt procedure, nopass :: get_id => z_as_smoother_get_id end type mld_z_as_smoother_type @@ -98,7 +99,8 @@ module mld_z_as_smoother private :: z_as_smoother_descr, z_as_smoother_sizeof, & & z_as_smoother_default, z_as_smoother_get_nzeros, & - & z_as_smoother_get_fmt, z_as_smoother_get_id + & z_as_smoother_get_fmt, z_as_smoother_get_id, & + & z_as_smoother_get_wrksize character(len=6), parameter, private :: & & restrict_names(0:4)=(/'none ','halo ',' ',' ',' '/) @@ -458,6 +460,16 @@ contains end subroutine z_as_smoother_descr + function z_as_smoother_get_wrksize(sm) result(val) + implicit none + class(mld_z_as_smoother_type), intent(inout) :: sm + integer(psb_ipk_) :: val + + val = 3 + if (allocated(sm%sv)) val = val + sm%sv%get_wrksz() + + end function z_as_smoother_get_wrksize + function z_as_smoother_get_fmt() result(val) implicit none character(len=32) :: val diff --git a/mlprec/mld_z_base_smoother_mod.f90 b/mlprec/mld_z_base_smoother_mod.f90 index 98b01657..9b607ecf 100644 --- a/mlprec/mld_z_base_smoother_mod.f90 +++ b/mlprec/mld_z_base_smoother_mod.f90 @@ -92,6 +92,10 @@ module mld_z_base_smoother_mod ! check - Sanity checks. ! sizeof - Total memory occupation in bytes ! get_nzeros - Number of nonzeros + ! stringval - convert string to val for internal parms + ! get_fmt - short string descriptor + ! get_id - numeric id descriptro + ! get_wrksz - How many workspace vector does apply_vect need ! ! ! @@ -119,6 +123,7 @@ module mld_z_base_smoother_mod procedure, pass(sm) :: descr => mld_z_base_smoother_descr procedure, pass(sm) :: sizeof => z_base_smoother_sizeof procedure, pass(sm) :: get_nzeros => z_base_smoother_get_nzeros + procedure, pass(sm) :: get_wrksz => z_base_smoother_get_wrksize procedure, nopass :: stringval => mld_stringval procedure, nopass :: get_fmt => z_base_smoother_get_fmt procedure, nopass :: get_id => z_base_smoother_get_id @@ -127,7 +132,7 @@ module mld_z_base_smoother_mod private :: z_base_smoother_sizeof, z_base_smoother_get_fmt, & & z_base_smoother_default, z_base_smoother_get_nzeros, & - & z_base_smoother_get_id + & z_base_smoother_get_id, z_base_smoother_get_wrksize @@ -387,6 +392,16 @@ contains return end subroutine z_base_smoother_default + function z_base_smoother_get_wrksize(sm) result(val) + implicit none + class(mld_z_base_smoother_type), intent(inout) :: sm + integer(psb_ipk_) :: val + + val = 0 + if (allocated(sm%sv)) val = val + sm%sv%get_wrksz() + + end function z_base_smoother_get_wrksize + function z_base_smoother_get_fmt() result(val) implicit none character(len=32) :: val diff --git a/mlprec/mld_z_base_solver_mod.f90 b/mlprec/mld_z_base_solver_mod.f90 index cde508d9..9a2b3836 100644 --- a/mlprec/mld_z_base_solver_mod.f90 +++ b/mlprec/mld_z_base_solver_mod.f90 @@ -78,7 +78,10 @@ module mld_z_base_solver_mod ! check - Sanity checks. ! sizeof - Total memory occupation in bytes ! get_nzeros - Number of nonzeros - ! + ! stringval - convert string to val for internal parms + ! get_fmt - short string descriptor + ! get_id - numeric id descriptro + ! get_wrksz - How many workspace vector does apply_vect need ! ! @@ -104,6 +107,7 @@ module mld_z_base_solver_mod procedure, pass(sv) :: descr => mld_z_base_solver_descr procedure, pass(sv) :: sizeof => z_base_solver_sizeof procedure, pass(sv) :: get_nzeros => z_base_solver_get_nzeros + procedure, nopass :: get_wrksz => z_base_solver_get_wrksize procedure, nopass :: stringval => mld_stringval procedure, nopass :: get_fmt => z_base_solver_get_fmt procedure, nopass :: get_id => z_base_solver_get_id @@ -112,7 +116,8 @@ module mld_z_base_solver_mod private :: z_base_solver_sizeof, z_base_solver_default,& & z_base_solver_get_nzeros, z_base_solver_get_fmt, & - & z_base_solver_is_iterative, z_base_solver_get_id + & z_base_solver_is_iterative, z_base_solver_get_id, & + & z_base_solver_get_wrksize interface @@ -411,5 +416,11 @@ contains val = mld_f_none_ end function z_base_solver_get_id + function z_base_solver_get_wrksize() result(val) + implicit none + integer(psb_ipk_) :: val + + val = 0 + end function z_base_solver_get_wrksize end module mld_z_base_solver_mod diff --git a/mlprec/mld_z_gs_solver.f90 b/mlprec/mld_z_gs_solver.f90 index 6f408797..de494bfa 100644 --- a/mlprec/mld_z_gs_solver.f90 +++ b/mlprec/mld_z_gs_solver.f90 @@ -77,6 +77,7 @@ module mld_z_gs_solver procedure, pass(sv) :: default => z_gs_solver_default procedure, pass(sv) :: sizeof => z_gs_solver_sizeof procedure, pass(sv) :: get_nzeros => z_gs_solver_get_nzeros + procedure, nopass :: get_wrksz => z_gs_solver_get_wrksize procedure, nopass :: get_fmt => z_gs_solver_get_fmt procedure, nopass :: get_id => z_gs_solver_get_id procedure, nopass :: is_iterative => z_gs_solver_is_iterative @@ -102,7 +103,7 @@ module mld_z_gs_solver & z_gs_solver_get_fmt, z_gs_solver_check,& & z_gs_solver_is_iterative, & & z_bwgs_solver_get_fmt, z_bwgs_solver_descr, & - & z_gs_solver_get_id, z_bwgs_solver_get_id + & z_gs_solver_get_id, z_bwgs_solver_get_id, z_gs_solver_get_wrksize interface subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& @@ -642,4 +643,11 @@ contains val = mld_bwgs_ end function z_bwgs_solver_get_id + function z_gs_solver_get_wrksize() result(val) + implicit none + integer(psb_ipk_) :: val + + val = 2 + end function z_gs_solver_get_wrksize + end module mld_z_gs_solver diff --git a/mlprec/mld_z_ilu_solver.f90 b/mlprec/mld_z_ilu_solver.f90 index 2fba0b53..c9635860 100644 --- a/mlprec/mld_z_ilu_solver.f90 +++ b/mlprec/mld_z_ilu_solver.f90 @@ -85,6 +85,7 @@ module mld_z_ilu_solver procedure, pass(sv) :: default => z_ilu_solver_default procedure, pass(sv) :: sizeof => z_ilu_solver_sizeof procedure, pass(sv) :: get_nzeros => z_ilu_solver_get_nzeros + procedure, nopass :: get_wrksz => z_ilu_solver_get_wrksize procedure, nopass :: get_fmt => z_ilu_solver_get_fmt procedure, nopass :: get_id => z_ilu_solver_get_id end type mld_z_ilu_solver_type @@ -96,7 +97,8 @@ module mld_z_ilu_solver & z_ilu_solver_descr, z_ilu_solver_sizeof, & & z_ilu_solver_default, z_ilu_solver_dmp, & & z_ilu_solver_apply_vect, z_ilu_solver_get_nzeros, & - & z_ilu_solver_get_fmt, z_ilu_solver_check, z_ilu_solver_get_id + & z_ilu_solver_get_fmt, z_ilu_solver_check, & + & z_ilu_solver_get_id, z_ilu_solver_get_wrksize interface @@ -554,5 +556,12 @@ contains val = mld_ilu_n_ end function z_ilu_solver_get_id + + function z_ilu_solver_get_wrksize() result(val) + implicit none + integer(psb_ipk_) :: val + + val = 2 + end function z_ilu_solver_get_wrksize end module mld_z_ilu_solver diff --git a/mlprec/mld_z_jac_smoother.f90 b/mlprec/mld_z_jac_smoother.f90 index 1e6146a7..08cf38f3 100644 --- a/mlprec/mld_z_jac_smoother.f90 +++ b/mlprec/mld_z_jac_smoother.f90 @@ -71,6 +71,7 @@ module mld_z_jac_smoother procedure, pass(sm) :: descr => mld_z_jac_smoother_descr procedure, pass(sm) :: sizeof => z_jac_smoother_sizeof procedure, pass(sm) :: get_nzeros => z_jac_smoother_get_nzeros + procedure, pass(sm) :: get_wrksz => z_jac_smoother_get_wrksize procedure, nopass :: get_fmt => z_jac_smoother_get_fmt procedure, nopass :: get_id => z_jac_smoother_get_id end type mld_z_jac_smoother_type @@ -78,7 +79,8 @@ module mld_z_jac_smoother private :: z_jac_smoother_free, z_jac_smoother_descr, & & z_jac_smoother_sizeof, z_jac_smoother_get_nzeros, & - & z_jac_smoother_get_fmt, z_jac_smoother_get_id + & z_jac_smoother_get_fmt, z_jac_smoother_get_id, & + & z_jac_smoother_get_wrksize interface @@ -253,6 +255,16 @@ contains return end function z_jac_smoother_get_nzeros + function z_jac_smoother_get_wrksize(sm) result(val) + implicit none + class(mld_z_jac_smoother_type), intent(inout) :: sm + integer(psb_ipk_) :: val + + val = 2 + if (allocated(sm%sv)) val = val + sm%sv%get_wrksz() + + end function z_jac_smoother_get_wrksize + function z_jac_smoother_get_fmt() result(val) implicit none character(len=32) :: val diff --git a/mlprec/mld_z_onelev_mod.f90 b/mlprec/mld_z_onelev_mod.f90 index 54be4ab0..4fe7351a 100644 --- a/mlprec/mld_z_onelev_mod.f90 +++ b/mlprec/mld_z_onelev_mod.f90 @@ -117,11 +117,20 @@ module mld_z_onelev_mod ! check - Sanity checks. ! sizeof - Total memory occupation in bytes ! get_nzeros - Number of nonzeros + ! get_wrksz - How many workspace vector does apply_vect need ! - ! + ! + type mld_zmlprec_wrk_type + complex(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + type(psb_z_vect_type) :: vtx, vty, vx2l, vy2l + integer(psb_ipk_) :: wvsz = 0 + type(psb_z_vect_type), allocatable :: wv(:) + end type mld_zmlprec_wrk_type + type mld_z_onelev_type class(mld_z_base_smoother_type), allocatable :: sm, sm2a class(mld_z_base_smoother_type), pointer :: sm2 => null() + type(mld_zmlprec_wrk_type) :: wrk type(mld_dml_parms) :: parms type(psb_zspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -153,6 +162,7 @@ module mld_z_onelev_mod & cseti, csetr, csetc, setsm, setsv procedure, pass(lv) :: sizeof => z_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => z_base_onelev_get_nzeros + procedure, pass(lv) :: get_wrksz => z_base_onelev_get_wrksize procedure, nopass :: stringval => mld_stringval procedure, pass(lv) :: move_alloc => z_base_onelev_move_alloc end type mld_z_onelev_type @@ -164,7 +174,8 @@ module mld_z_onelev_mod private :: z_base_onelev_default, z_base_onelev_sizeof, & & z_base_onelev_nullify, z_base_onelev_get_nzeros, & - & z_base_onelev_clone, z_base_onelev_move_alloc + & z_base_onelev_clone, z_base_onelev_move_alloc, & + & z_base_onelev_get_wrksize @@ -498,7 +509,6 @@ contains end subroutine z_base_onelev_clone - subroutine z_base_onelev_move_alloc(lv, b,info) use psb_base_mod implicit none @@ -527,4 +537,41 @@ contains end subroutine z_base_onelev_move_alloc + + function z_base_onelev_get_wrksize(lv) result(val) + implicit none + class(mld_z_base_onelev_type), intent(inout) :: lv + integer(psb_ipk_) :: val + + val = 0 + ! SM and SM2A can share work vectors + if (allocated(lv%sm)) val = val + sm%get_wrksz() + if (allocated(lv%sm2a)) val = max(val,sm2a%get_wrksz()) + ! + ! Now for the ML application itself + ! + ! We have VTX/VTY/VX2L/VY2L + ! + val = val + 4 + ! + ! plus some additions for specific ML/cycles + ! + select case(lv%parms%ml_cycle) + case(mld_add_ml_,mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_) + ! We're good + + case(mld_kcycle_ml_, mld_kcyclesym_ml_) + ! + ! We need 7 in inneritkcycle, but we can reuse vtx + ! + val = val + 6 + + case default + ! Need a better error signaling ? + val = -1 + end select + + end function z_base_onelev_get_wrksize + + end module mld_z_onelev_mod diff --git a/mlprec/mld_z_prec_type.f90 b/mlprec/mld_z_prec_type.f90 index aa06cf25..1728a1b3 100644 --- a/mlprec/mld_z_prec_type.f90 +++ b/mlprec/mld_z_prec_type.f90 @@ -80,12 +80,6 @@ module mld_z_prec_type ! order, with level 0 being the id of the coarsest level. ! ! - - 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 From 08040c455b462881036c1d84ec08c40b2b63ff85 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 8 Dec 2017 10:19:26 +0000 Subject: [PATCH 06/16] Added level%allocate_wrk. Fix wrksize calculation. --- mlprec/mld_c_onelev_mod.f90 | 35 ++++++++++++++++++++++++++++++----- mlprec/mld_c_prec_type.f90 | 2 ++ mlprec/mld_d_onelev_mod.f90 | 35 ++++++++++++++++++++++++++++++----- mlprec/mld_d_prec_type.f90 | 2 ++ mlprec/mld_s_onelev_mod.f90 | 35 ++++++++++++++++++++++++++++++----- mlprec/mld_s_prec_type.f90 | 2 ++ mlprec/mld_z_onelev_mod.f90 | 35 ++++++++++++++++++++++++++++++----- mlprec/mld_z_prec_type.f90 | 2 ++ 8 files changed, 128 insertions(+), 20 deletions(-) diff --git a/mlprec/mld_c_onelev_mod.f90 b/mlprec/mld_c_onelev_mod.f90 index f19ce582..d42b2b0e 100644 --- a/mlprec/mld_c_onelev_mod.f90 +++ b/mlprec/mld_c_onelev_mod.f90 @@ -163,6 +163,8 @@ module mld_c_onelev_mod procedure, pass(lv) :: sizeof => c_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => c_base_onelev_get_nzeros procedure, pass(lv) :: get_wrksz => c_base_onelev_get_wrksize + procedure, pass(lv) :: allocate_wrk => c_base_onelev_allocate_wrk + procedure, pass(lv) :: free_wrk => c_base_onelev_free_wrk procedure, nopass :: stringval => mld_stringval procedure, pass(lv) :: move_alloc => c_base_onelev_move_alloc end type mld_c_onelev_type @@ -175,7 +177,7 @@ module mld_c_onelev_mod private :: c_base_onelev_default, c_base_onelev_sizeof, & & c_base_onelev_nullify, c_base_onelev_get_nzeros, & & c_base_onelev_clone, c_base_onelev_move_alloc, & - & c_base_onelev_get_wrksize + & c_base_onelev_get_wrksize, c_base_onelev_allocate_wrk, c_base_onelev_free_wrk @@ -540,13 +542,13 @@ contains function c_base_onelev_get_wrksize(lv) result(val) implicit none - class(mld_c_base_onelev_type), intent(inout) :: lv + class(mld_c_onelev_type), intent(inout) :: lv integer(psb_ipk_) :: val val = 0 ! SM and SM2A can share work vectors - if (allocated(lv%sm)) val = val + sm%get_wrksz() - if (allocated(lv%sm2a)) val = max(val,sm2a%get_wrksz()) + if (allocated(lv%sm)) val = val + lv%sm%get_wrksz() + if (allocated(lv%sm2a)) val = max(val,lv%sm2a%get_wrksz()) ! ! Now for the ML application itself ! @@ -572,6 +574,29 @@ contains end select end function c_base_onelev_get_wrksize + + subroutine c_base_onelev_allocate_wrk(lv,info,vmold) + use psb_base_mod + implicit none + class(mld_c_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_vect_type), intent(in), optional :: vmold + ! + integer(psb_ipk_) :: nwv + info = psb_success_ + nwv = lv%get_wrksz() + write(0,*) 'Debug allocate_wrk: ',nwv + end subroutine c_base_onelev_allocate_wrk + - + subroutine c_base_onelev_free_wrk(lv,info) + use psb_base_mod + implicit none + class(mld_c_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: nwv + info = psb_success_ + end subroutine c_base_onelev_free_wrk + end module mld_c_onelev_mod diff --git a/mlprec/mld_c_prec_type.f90 b/mlprec/mld_c_prec_type.f90 index 092fe9ad..2ebdbc1c 100644 --- a/mlprec/mld_c_prec_type.f90 +++ b/mlprec/mld_c_prec_type.f90 @@ -851,6 +851,7 @@ contains 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) @@ -909,6 +910,7 @@ contains 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) diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index 23c35311..bb6ae569 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -163,6 +163,8 @@ module mld_d_onelev_mod procedure, pass(lv) :: sizeof => d_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros procedure, pass(lv) :: get_wrksz => d_base_onelev_get_wrksize + procedure, pass(lv) :: allocate_wrk => d_base_onelev_allocate_wrk + procedure, pass(lv) :: free_wrk => d_base_onelev_free_wrk procedure, nopass :: stringval => mld_stringval procedure, pass(lv) :: move_alloc => d_base_onelev_move_alloc end type mld_d_onelev_type @@ -175,7 +177,7 @@ module mld_d_onelev_mod private :: d_base_onelev_default, d_base_onelev_sizeof, & & d_base_onelev_nullify, d_base_onelev_get_nzeros, & & d_base_onelev_clone, d_base_onelev_move_alloc, & - & d_base_onelev_get_wrksize + & d_base_onelev_get_wrksize, d_base_onelev_allocate_wrk, d_base_onelev_free_wrk @@ -540,13 +542,13 @@ contains function d_base_onelev_get_wrksize(lv) result(val) implicit none - class(mld_d_base_onelev_type), intent(inout) :: lv + class(mld_d_onelev_type), intent(inout) :: lv integer(psb_ipk_) :: val val = 0 ! SM and SM2A can share work vectors - if (allocated(lv%sm)) val = val + sm%get_wrksz() - if (allocated(lv%sm2a)) val = max(val,sm2a%get_wrksz()) + if (allocated(lv%sm)) val = val + lv%sm%get_wrksz() + if (allocated(lv%sm2a)) val = max(val,lv%sm2a%get_wrksz()) ! ! Now for the ML application itself ! @@ -572,6 +574,29 @@ contains end select end function d_base_onelev_get_wrksize + + subroutine d_base_onelev_allocate_wrk(lv,info,vmold) + use psb_base_mod + implicit none + class(mld_d_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_vect_type), intent(in), optional :: vmold + ! + integer(psb_ipk_) :: nwv + info = psb_success_ + nwv = lv%get_wrksz() + write(0,*) 'Debug allocate_wrk: ',nwv + end subroutine d_base_onelev_allocate_wrk + - + subroutine d_base_onelev_free_wrk(lv,info) + use psb_base_mod + implicit none + class(mld_d_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: nwv + info = psb_success_ + end subroutine d_base_onelev_free_wrk + end module mld_d_onelev_mod diff --git a/mlprec/mld_d_prec_type.f90 b/mlprec/mld_d_prec_type.f90 index 7cb2ff75..aaefadfc 100644 --- a/mlprec/mld_d_prec_type.f90 +++ b/mlprec/mld_d_prec_type.f90 @@ -851,6 +851,7 @@ contains 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) @@ -909,6 +910,7 @@ contains 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) diff --git a/mlprec/mld_s_onelev_mod.f90 b/mlprec/mld_s_onelev_mod.f90 index df8b78b2..c81488ac 100644 --- a/mlprec/mld_s_onelev_mod.f90 +++ b/mlprec/mld_s_onelev_mod.f90 @@ -163,6 +163,8 @@ module mld_s_onelev_mod procedure, pass(lv) :: sizeof => s_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => s_base_onelev_get_nzeros procedure, pass(lv) :: get_wrksz => s_base_onelev_get_wrksize + procedure, pass(lv) :: allocate_wrk => s_base_onelev_allocate_wrk + procedure, pass(lv) :: free_wrk => s_base_onelev_free_wrk procedure, nopass :: stringval => mld_stringval procedure, pass(lv) :: move_alloc => s_base_onelev_move_alloc end type mld_s_onelev_type @@ -175,7 +177,7 @@ module mld_s_onelev_mod private :: s_base_onelev_default, s_base_onelev_sizeof, & & s_base_onelev_nullify, s_base_onelev_get_nzeros, & & s_base_onelev_clone, s_base_onelev_move_alloc, & - & s_base_onelev_get_wrksize + & s_base_onelev_get_wrksize, s_base_onelev_allocate_wrk, s_base_onelev_free_wrk @@ -540,13 +542,13 @@ contains function s_base_onelev_get_wrksize(lv) result(val) implicit none - class(mld_s_base_onelev_type), intent(inout) :: lv + class(mld_s_onelev_type), intent(inout) :: lv integer(psb_ipk_) :: val val = 0 ! SM and SM2A can share work vectors - if (allocated(lv%sm)) val = val + sm%get_wrksz() - if (allocated(lv%sm2a)) val = max(val,sm2a%get_wrksz()) + if (allocated(lv%sm)) val = val + lv%sm%get_wrksz() + if (allocated(lv%sm2a)) val = max(val,lv%sm2a%get_wrksz()) ! ! Now for the ML application itself ! @@ -572,6 +574,29 @@ contains end select end function s_base_onelev_get_wrksize + + subroutine s_base_onelev_allocate_wrk(lv,info,vmold) + use psb_base_mod + implicit none + class(mld_s_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_vect_type), intent(in), optional :: vmold + ! + integer(psb_ipk_) :: nwv + info = psb_success_ + nwv = lv%get_wrksz() + write(0,*) 'Debug allocate_wrk: ',nwv + end subroutine s_base_onelev_allocate_wrk + - + subroutine s_base_onelev_free_wrk(lv,info) + use psb_base_mod + implicit none + class(mld_s_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: nwv + info = psb_success_ + end subroutine s_base_onelev_free_wrk + end module mld_s_onelev_mod diff --git a/mlprec/mld_s_prec_type.f90 b/mlprec/mld_s_prec_type.f90 index 59145790..9b1efb2e 100644 --- a/mlprec/mld_s_prec_type.f90 +++ b/mlprec/mld_s_prec_type.f90 @@ -851,6 +851,7 @@ contains 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) @@ -909,6 +910,7 @@ contains 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) diff --git a/mlprec/mld_z_onelev_mod.f90 b/mlprec/mld_z_onelev_mod.f90 index 4fe7351a..619c4053 100644 --- a/mlprec/mld_z_onelev_mod.f90 +++ b/mlprec/mld_z_onelev_mod.f90 @@ -163,6 +163,8 @@ module mld_z_onelev_mod procedure, pass(lv) :: sizeof => z_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => z_base_onelev_get_nzeros procedure, pass(lv) :: get_wrksz => z_base_onelev_get_wrksize + procedure, pass(lv) :: allocate_wrk => z_base_onelev_allocate_wrk + procedure, pass(lv) :: free_wrk => z_base_onelev_free_wrk procedure, nopass :: stringval => mld_stringval procedure, pass(lv) :: move_alloc => z_base_onelev_move_alloc end type mld_z_onelev_type @@ -175,7 +177,7 @@ module mld_z_onelev_mod private :: z_base_onelev_default, z_base_onelev_sizeof, & & z_base_onelev_nullify, z_base_onelev_get_nzeros, & & z_base_onelev_clone, z_base_onelev_move_alloc, & - & z_base_onelev_get_wrksize + & z_base_onelev_get_wrksize, z_base_onelev_allocate_wrk, z_base_onelev_free_wrk @@ -540,13 +542,13 @@ contains function z_base_onelev_get_wrksize(lv) result(val) implicit none - class(mld_z_base_onelev_type), intent(inout) :: lv + class(mld_z_onelev_type), intent(inout) :: lv integer(psb_ipk_) :: val val = 0 ! SM and SM2A can share work vectors - if (allocated(lv%sm)) val = val + sm%get_wrksz() - if (allocated(lv%sm2a)) val = max(val,sm2a%get_wrksz()) + if (allocated(lv%sm)) val = val + lv%sm%get_wrksz() + if (allocated(lv%sm2a)) val = max(val,lv%sm2a%get_wrksz()) ! ! Now for the ML application itself ! @@ -572,6 +574,29 @@ contains end select end function z_base_onelev_get_wrksize + + subroutine z_base_onelev_allocate_wrk(lv,info,vmold) + use psb_base_mod + implicit none + class(mld_z_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_vect_type), intent(in), optional :: vmold + ! + integer(psb_ipk_) :: nwv + info = psb_success_ + nwv = lv%get_wrksz() + write(0,*) 'Debug allocate_wrk: ',nwv + end subroutine z_base_onelev_allocate_wrk + - + subroutine z_base_onelev_free_wrk(lv,info) + use psb_base_mod + implicit none + class(mld_z_onelev_type), target, intent(inout) :: lv + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: nwv + info = psb_success_ + end subroutine z_base_onelev_free_wrk + end module mld_z_onelev_mod diff --git a/mlprec/mld_z_prec_type.f90 b/mlprec/mld_z_prec_type.f90 index 1728a1b3..d5662f15 100644 --- a/mlprec/mld_z_prec_type.f90 +++ b/mlprec/mld_z_prec_type.f90 @@ -851,6 +851,7 @@ contains 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) @@ -909,6 +910,7 @@ contains 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) From 6f9a3c10d246b66ac426f081586eda073f0dc271 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 8 Dec 2017 15:17:31 +0000 Subject: [PATCH 07/16] Use ASSOCIATE for wrk vectors. KCYCLE to be debugged. --- mlprec/impl/mld_cmlprec_aply.f90 | 977 ++++++++++++++++--------------- mlprec/impl/mld_dmlprec_aply.f90 | 977 ++++++++++++++++--------------- mlprec/impl/mld_smlprec_aply.f90 | 977 ++++++++++++++++--------------- mlprec/impl/mld_zmlprec_aply.f90 | 977 ++++++++++++++++--------------- mlprec/mld_c_onelev_mod.f90 | 24 +- mlprec/mld_d_onelev_mod.f90 | 24 +- mlprec/mld_s_onelev_mod.f90 | 24 +- mlprec/mld_z_onelev_mod.f90 | 24 +- 8 files changed, 2072 insertions(+), 1932 deletions(-) diff --git a/mlprec/impl/mld_cmlprec_aply.f90 b/mlprec/impl/mld_cmlprec_aply.f90 index 4378f3d6..11629f69 100644 --- a/mlprec/impl/mld_cmlprec_aply.f90 +++ b/mlprec/impl/mld_cmlprec_aply.f90 @@ -251,20 +251,50 @@ subroutine mld_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if - ! - ! At first iteration we must use the input BETA - ! - beta_ = beta - level = 1 - - call psb_geaxpby(cone,x,czero,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='geaxbpy') - goto 9999 - end if - - do isweep = 1, p%outer_sweeps - 1 + + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + ! + ! At first iteration we must use the input BETA + ! + beta_ = beta + + + call psb_geaxpby(cone,x,czero,vx2l,base_desc,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='geaxbpy') + goto 9999 + end if + + do isweep = 1, p%outer_sweeps - 1 + ! + ! With the current implementation, y2l is zeroed internally at first smoother. + ! call p%wrk(level)%vy2l%zero() + ! + call inner_ml_aply(level,p,trans_,work,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Inner prec aply') + goto 9999 + end if + call psb_geaxpby(alpha,vy2l,beta_,y,base_desc,info) + ! all iterations after the first must use BETA = 1 + beta_ = cone + ! + ! Next iteration should use the current residual to compute a correction + ! + call psb_geaxpby(cone,x,czero,vx2l,base_desc,info) + call psb_spmm(-cone,base_a,y,cone,vx2l,base_desc,info) + end do + + ! + ! If outer_sweeps == 1 we have just skipped the loop, and it's + ! equivalent to a single application. + ! + ! ! With the current implementation, y2l is zeroed internally at first smoother. ! call p%wrk(level)%vy2l%zero() @@ -276,38 +306,9 @@ subroutine mld_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) & a_err='Inner prec aply') goto 9999 end if - call psb_geaxpby(alpha,p%wrk(level)%vy2l,beta_,y,& - & p%precv(level)%base_desc,info) - ! all iterations after the first must use BETA = 1 - beta_ = cone - ! - ! Next iteration should use the current residual to compute a correction - ! - call psb_geaxpby(cone,x,czero,p%wrk(level)%vx2l,& - & p%precv(level)%base_desc,info) - call psb_spmm(-cone,p%precv(level)%base_a,y,& - & cone,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) - end do - - ! - ! If outer_sweeps == 1 we have just skipped the loop, and it's - ! equivalent to a single application. - ! - - ! - ! With the current implementation, y2l is zeroed internally at first smoother. - ! call p%wrk(level)%vy2l%zero() - ! - call inner_ml_aply(level,p,trans_,work,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Inner prec aply') - goto 9999 - end if - call psb_geaxpby(alpha,p%wrk(level)%vy2l,beta_,y,& - & p%precv(level)%base_desc,info) - + call psb_geaxpby(alpha,vy2l,beta_,y,base_desc,info) + + end associate if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error final update') @@ -479,70 +480,75 @@ contains goto 9999 end if - if (allocated(p%precv(level)%sm2a)) then - call psb_geaxpby(cone,& - & p%wrk(level)%vx2l,czero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc,info) + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + + if (allocated(p%precv(level)%sm2a)) then + call psb_geaxpby(cone,& + & vx2l,czero,vy2l,& + & base_desc,info) + + sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post) + do k=1, sweeps + call p%precv(level)%sm%apply(cone,& + & vy2l,czero,vty,& + & base_desc, trans,& + & ione,work,info,init='Z') + + call p%precv(level)%sm2a%apply(cone,& + & vty,czero,vy2l,& + & base_desc, trans,& + & ione,work,info,init='Z') + end do - sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post) - do k=1, sweeps + else + sweeps = p%precv(level)%parms%sweeps_pre call p%precv(level)%sm%apply(cone,& - & p%wrk(level)%vy2l,czero,p%wrk(level)%vtx,& - & p%precv(level)%base_desc, trans,& - & ione,work,info,init='Z') - - call p%precv(level)%sm2a%apply(cone,& - & p%wrk(level)%vtx,czero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & ione,work,info,init='Z') - end do - - else - sweeps = p%precv(level)%parms%sweeps_pre - call p%precv(level)%sm%apply(cone,& - & p%wrk(level)%vx2l,czero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during ADD smoother_apply') - goto 9999 - end if - - if (level < nlev) then - ! Apply the restriction - call psb_map_X2Y(cone,p%wrk(level)%vx2l,& - & czero,p%wrk(level+1)%vx2l,& - & 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 restriction') - goto 9999 + & vx2l,czero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') end if - - call inner_ml_aply(level+1,p,trans,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') + & a_err='Error during ADD smoother_apply') goto 9999 end if - ! - ! Apply the prolongator - ! - call psb_map_Y2X(cone,p%wrk(level+1)%vy2l,& - & cone,p%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 (level < nlev) then + ! Apply the restriction + call psb_map_X2Y(cone,vx2l,& + & czero,p%precv(level+1)%wrk%vx2l,& + & 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 restriction') + goto 9999 + end if + + call inner_ml_aply(level+1,p,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 + ! + ! Apply the prolongator + ! + call psb_map_Y2X(cone,p%precv(level+1)%wrk%vy2l,& + & cone,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 - end if + end if + end associate + call psb_erractionrestore(err_act) return @@ -597,170 +603,174 @@ contains pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) - if (level < nlev) then - ! - ! Apply the first smoother - ! The residual has been prepared before the recursive call. - ! + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + if (level < nlev) then + ! + ! Apply the first smoother + ! The residual has been prepared before the recursive call. + ! - if (pre) then - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & p%wrk(level)%vx2l,czero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') + if (pre) then + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & vx2l,czero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& + & vx2l,czero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during PRE smoother_apply') + goto 9999 + end if + endif + ! + ! Compute the residual and call recursively + ! + if (pre) then + call psb_geaxpby(cone,vx2l,& + & czero,vty,& + & base_desc,info) + + if (info == psb_success_) call psb_spmm(-cone,base_a,& + & vy2l,cone,vty,& + & base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + call psb_map_X2Y(cone,vty,& + & czero,p%precv(level+1)%wrk%vx2l,& + & 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 restriction') + goto 9999 + end if else - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& - & p%wrk(level)%vx2l,czero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during PRE smoother_apply') - goto 9999 - end if - endif - ! - ! Compute the residual and call recursively - ! - if (pre) then - call psb_geaxpby(cone,p%wrk(level)%vx2l,& - & czero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - - if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& - & p%wrk(level)%vy2l,cone,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - call psb_map_X2Y(cone,p%wrk(level)%vty,& - & czero,p%wrk(level+1)%vx2l,& - & 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 restriction') - goto 9999 - end if - else - ! Shortcut: just transfer x2l. - call psb_map_X2Y(cone,p%wrk(level)%vx2l,& - & czero,p%wrk(level+1)%vx2l,& + ! Shortcut: just transfer x2l. + call psb_map_X2Y(cone,vx2l,& + & czero,p%precv(level+1)%wrk%vx2l,& + & 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 restriction') + goto 9999 + end if + endif + + call inner_ml_aply(level+1,p,trans,work,info) + + ! + ! Apply the prolongator + ! + call psb_map_Y2X(cone,p%precv(level+1)%wrk%vy2l,& + & cone,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 restriction') + & a_err='Error during prolongation') goto 9999 end if - endif - call inner_ml_aply(level+1,p,trans,work,info) + if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then + + call psb_geaxpby(cone,vx2l,& + & czero,vty,& + & base_desc,info) + if (info == psb_success_) call psb_spmm(-cone,base_a,& + & vy2l,cone,vty,& + & base_desc,info,work=work,trans=trans) + if (info == psb_success_) call psb_map_X2Y(cone,vty,& + & czero,p%precv(level+1)%wrk%vx2l,& + & 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 W-cycle restriction') + goto 9999 + end if + + call inner_ml_aply(level+1,p,trans,work,info) + + if (info == psb_success_) call psb_map_Y2X(cone,p%precv(level+1)%wrk%vy2l,& + & cone,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 W recusion/prolongation') + goto 9999 + end if - ! - ! Apply the prolongator - ! - call psb_map_Y2X(cone,p%wrk(level+1)%vy2l,& - & cone,p%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 + endif - if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then - - call psb_geaxpby(cone,p%wrk(level)%vx2l,& - & czero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& - & p%wrk(level)%vy2l,cone,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info == psb_success_) call psb_map_X2Y(cone,p%wrk(level)%vty,& - & czero,p%wrk(level+1)%vx2l,& - & 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 W-cycle restriction') - goto 9999 - end if - - call inner_ml_aply(level+1,p,trans,work,info) - - if (info == psb_success_) call psb_map_Y2X(cone,p%wrk(level+1)%vy2l,& - & cone,p%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 W recusion/prolongation') - goto 9999 - end if - - endif - - - if (post) then - call psb_geaxpby(cone,p%wrk(level)%vx2l,& - & czero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& - & p%wrk(level)%vy2l,& - & cone,p%wrk(level)%vty,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the second smoother - ! - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& - & p%wrk(level)%vty,cone,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - else - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & p%wrk(level)%vty,cone,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during POST smoother_apply') - goto 9999 - end if - - endif - - else if (level == nlev) then - - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & p%wrk(level)%vx2l,czero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (post) then + call psb_geaxpby(cone,vx2l,& + & czero,vty,& + & base_desc,info) + if (info == psb_success_) call psb_spmm(-cone,base_a,& + & vy2l,& + & cone,vty,base_desc,info,& + & work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + + ! + ! Apply the second smoother + ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& + & vty,cone,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & vty,cone,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during POST smoother_apply') + goto 9999 + end if - else + endif - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL vs NLEV') - goto 9999 - end if + else if (level == nlev) then + + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & vx2l,czero,vy2l,& + & base_desc, trans,& + & sweeps,work,info) + else + + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') + goto 9999 + end if + end associate + call psb_erractionrestore(err_act) return @@ -824,147 +834,150 @@ contains !K cycle - if (level == nlev) then - ! - ! Apply smoother - ! - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & p%wrk(level)%vx2l,czero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - - else if (level < nlev) then - - if (trans == 'N') then + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + if (level == nlev) then + ! + ! Apply smoother + ! sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & p%wrk(level)%vx2l,czero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - else - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& - & p%wrk(level)%vx2l,czero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& + & vx2l,czero,vy2l,& + & base_desc, trans,& & sweeps,work,info,init='Z') - end if - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-PRE smoother_apply') - goto 9999 - end if - + else if (level < nlev) then - ! - ! Compute the residual and call recursively - ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & vx2l,czero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& + & vx2l,czero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + end if - call psb_geaxpby(cone,p%wrk(level)%vx2l,& - & czero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - - if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& - & p%wrk(level)%vy2l,cone,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during 2-PRE smoother_apply') + goto 9999 + end if - ! Apply the restriction - call psb_map_X2Y(cone,p%wrk(level)%vty,& - & czero,p%wrk(level + 1)%vx2l,& - & 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 restriction') - goto 9999 - end if + ! + ! Compute the residual and call recursively + ! - !Set the preconditioner + call psb_geaxpby(cone,vx2l,& + & czero,vty,& + & base_desc,info) - if (level <= nlev - 2 ) then - if (p%precv(level)%parms%ml_cycle == mld_kcyclesym_ml_) then - call mld_cinneritkcycle(p, level + 1, trans, work, 'FCG') - elseif (p%precv(level)%parms%ml_cycle == mld_kcycle_ml_) then - call mld_cinneritkcycle(p, level + 1, trans, work, 'GCR') - else + if (info == psb_success_) call psb_spmm(-cone,base_a,& + & vy2l,cone,vty,& + & base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Bad value for ml_cycle') + & a_err='Error during residue') goto 9999 + end if + + ! Apply the restriction + call psb_map_X2Y(cone,vty,& + & czero,p%precv(level + 1)%wrk%vx2l,& + & 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 restriction') + goto 9999 + end if + + !Set the preconditioner + + if (level <= nlev - 2 ) then + if (p%precv(level)%parms%ml_cycle == mld_kcyclesym_ml_) then + call mld_cinneritkcycle(p, level + 1, trans, work, 'FCG') + elseif (p%precv(level)%parms%ml_cycle == mld_kcycle_ml_) then + call mld_cinneritkcycle(p, level + 1, trans, work, 'GCR') + else + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Bad value for ml_cycle') + goto 9999 + endif + else + call inner_ml_aply(level + 1 ,p,trans,work,info) endif - else - call inner_ml_aply(level + 1 ,p,trans,work,info) - endif - 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_) 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,p%wrk(level+1)%vy2l,& - & cone,p%wrk(level)%vy2l,& - & p%precv(level+1)%map,info,work=work) + ! + ! Apply the prolongator + ! + call psb_map_Y2X(cone,p%precv(level+1)%wrk%vy2l,& + & cone,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_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during prolongation') + goto 9999 + end if - ! - ! Compute the residual - ! - call psb_geaxpby(cone,p%wrk(level)%vx2l,& - & czero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - call psb_spmm(-cone,p%precv(level)%base_a,p%wrk(level)%vy2l,& - & cone,p%wrk(level)%vty,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the smoother - ! - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& - & p%wrk(level)%vty,cone,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') + ! + ! Compute the residual + ! + call psb_geaxpby(cone,vx2l,& + & czero,vty,& + & base_desc,info) + call psb_spmm(-cone,base_a,vy2l,& + & cone,vty,base_desc,info,& + & work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + ! + ! Apply the smoother + ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& + & vty,cone,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & vty,cone,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during POST smoother_apply') + goto 9999 + end if else - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & p%wrk(level)%vty,cone,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during POST smoother_apply') + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') goto 9999 - end if - else - - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL vs NLEV') - goto 9999 - - endif + endif + end associate call psb_erractionrestore(err_act) return @@ -998,141 +1011,145 @@ contains complex(psb_spk_), allocatable :: temp_v(:) integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx character(len=20) :: name = 'innerit_k_cycle' - - !Assemble rhs, w, v, v1, x - - call psb_geasb(rhs,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - call psb_geasb(w,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - call psb_geasb(v,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - call psb_geasb(v1,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - call psb_geasb(x,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - !Assemble d(0) and d(1) - call psb_geasb(d(0),& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vy2l%v) - call psb_geasb(d(1),& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vy2l%v) - - - call x%zero() - - ! rhs=vx2l and w=rhs - call psb_geaxpby(cone,p%wrk(level)%vx2l,czero,rhs,& - & p%precv(level)%base_desc,info) - call psb_geaxpby(cone,p%wrk(level)%vx2l,czero,w,& - & p%precv(level)%base_desc,info) - - if (psb_errstatus_fatal()) then - nc2l = p%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 - - delta0 = psb_genrm2(w, p%precv(level)%base_desc, info) - - !Apply the preconditioner - call p%wrk(level)%vy2l%zero() - - idx=0 - call inner_ml_aply(level,p,trans,work,info) - - call psb_geaxpby(cone,p%wrk(level)%vy2l,czero,d(idx),p%precv(level)%base_desc,info) - - call psb_spmm(cone,p%precv(level)%base_a,d(idx),czero,v,p%precv(level)%base_desc,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - !FCG - if (psb_toupper(trim(innersolv)) == 'FCG') then - delta_old = psb_gedot(d(idx), w, p%precv(level)%base_desc, info) - tau = psb_gedot(d(idx), v, p%precv(level)%base_desc, info) - !GCR - else if (psb_toupper(trim(innersolv)) == 'GCR') then - delta_old = psb_gedot(v, w, p%precv(level)%base_desc, info) - tau = psb_gedot(v, v, p%precv(level)%base_desc, info) - else - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid inner solver') - goto 9999 - endif - alpha = delta_old/tau - !Update residual w - call psb_geaxpby(-alpha, v, cone, w, p%precv(level)%base_desc, info) + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + + !Assemble rhs, w, v, v1, x + + call psb_geasb(rhs,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + call psb_geasb(w,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + call psb_geasb(v,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + call psb_geasb(v1,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + call psb_geasb(x,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + !Assemble d(0) and d(1) + call psb_geasb(d(0),& + & base_desc,info,& + & scratch=.true.,mold=vy2l%v) + call psb_geasb(d(1),& + & base_desc,info,& + & scratch=.true.,mold=vy2l%v) + + + call x%zero() + + ! rhs=vx2l and w=rhs + call psb_geaxpby(cone,vx2l,czero,rhs,& + & base_desc,info) + call psb_geaxpby(cone,vx2l,czero,w,& + & base_desc,info) + + if (psb_errstatus_fatal()) then + nc2l = 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 - l2_norm = psb_genrm2(w, p%precv(level)%base_desc, info) - iter = 0 + delta0 = psb_genrm2(w, base_desc, info) - if (l2_norm <= rtol*delta0) then - !Update solution x - call psb_geaxpby(alpha, d(idx), cone, x, p%precv(level)%base_desc, info) - else - iter = iter + 1 - idx=mod(iter,2) + !Apply the preconditioner + call vy2l%zero() - !Apply preconditioner - call psb_geaxpby(cone,w,czero,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) + idx=0 call inner_ml_aply(level,p,trans,work,info) - call psb_geaxpby(cone,p%wrk(level)%vy2l,czero,d(idx),p%precv(level)%base_desc,info) - !Sparse matrix vector product + call psb_geaxpby(cone,vy2l,czero,d(idx),base_desc,info) - call psb_spmm(cone,p%precv(level)%base_a,d(idx),czero,v1,p%precv(level)%base_desc,info) + call psb_spmm(cone,base_a,d(idx),czero,v,base_desc,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') goto 9999 end if - !tau1, tau2, tau3, tau4 + !FCG if (psb_toupper(trim(innersolv)) == 'FCG') then - tau1= psb_gedot(d(idx), v, p%precv(level)%base_desc, info) - tau2= psb_gedot(d(idx), v1, p%precv(level)%base_desc, info) - tau3= psb_gedot(d(idx), w, p%precv(level)%base_desc, info) - tau4= tau2 - (tau1*tau1)/tau + delta_old = psb_gedot(d(idx), w, base_desc, info) + tau = psb_gedot(d(idx), v, base_desc, info) + !GCR else if (psb_toupper(trim(innersolv)) == 'GCR') then - tau1= psb_gedot(v1, v, p%precv(level)%base_desc, info) - tau2= psb_gedot(v1, v1, p%precv(level)%base_desc, info) - tau3= psb_gedot(v1, w, p%precv(level)%base_desc, info) - tau4= tau2 - (tau1*tau1)/tau + delta_old = psb_gedot(v, w, base_desc, info) + tau = psb_gedot(v, v, base_desc, info) else call psb_errpush(psb_err_internal_error_,name,& & a_err='Invalid inner solver') goto 9999 endif - !Update solution - alpha=alpha-(tau1*tau3)/(tau*tau4) - call psb_geaxpby(alpha,d(idx - 1),cone,x,p%precv(level)%base_desc,info) - alpha=tau3/tau4 - call psb_geaxpby(alpha,d(idx),cone,x,p%precv(level)%base_desc,info) - endif + alpha = delta_old/tau + !Update residual w + call psb_geaxpby(-alpha, v, cone, w, base_desc, info) + + l2_norm = psb_genrm2(w, base_desc, info) + iter = 0 + + if (l2_norm <= rtol*delta0) then + !Update solution x + call psb_geaxpby(alpha, d(idx), cone, x, base_desc, info) + else + iter = iter + 1 + idx=mod(iter,2) - call psb_geaxpby(cone,x,czero,p%wrk(level)%vy2l,p%precv(level)%base_desc,info) - !Free vectors - call psb_gefree(v, p%precv(level)%base_desc, info) - call psb_gefree(v1, p%precv(level)%base_desc, info) - call psb_gefree(w, p%precv(level)%base_desc, info) - call psb_gefree(x, p%precv(level)%base_desc, info) - call psb_gefree(d(0), p%precv(level)%base_desc, info) - call psb_gefree(d(1), p%precv(level)%base_desc, info) + !Apply preconditioner + call psb_geaxpby(cone,w,czero,vx2l,base_desc,info) + call inner_ml_aply(level,p,trans,work,info) + call psb_geaxpby(cone,vy2l,czero,d(idx),base_desc,info) + + !Sparse matrix vector product + + call psb_spmm(cone,base_a,d(idx),czero,v1,base_desc,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + + !tau1, tau2, tau3, tau4 + if (psb_toupper(trim(innersolv)) == 'FCG') then + tau1= psb_gedot(d(idx), v, base_desc, info) + tau2= psb_gedot(d(idx), v1, base_desc, info) + tau3= psb_gedot(d(idx), w, base_desc, info) + tau4= tau2 - (tau1*tau1)/tau + else if (psb_toupper(trim(innersolv)) == 'GCR') then + tau1= psb_gedot(v1, v, base_desc, info) + tau2= psb_gedot(v1, v1, base_desc, info) + tau3= psb_gedot(v1, w, base_desc, info) + tau4= tau2 - (tau1*tau1)/tau + else + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid inner solver') + goto 9999 + endif + + !Update solution + alpha=alpha-(tau1*tau3)/(tau*tau4) + call psb_geaxpby(alpha,d(idx - 1),cone,x,base_desc,info) + alpha=tau3/tau4 + call psb_geaxpby(alpha,d(idx),cone,x,base_desc,info) + endif + call psb_geaxpby(cone,x,czero,vy2l,base_desc,info) + !Free vectors + call psb_gefree(v, base_desc, info) + call psb_gefree(v1, base_desc, info) + call psb_gefree(w, base_desc, info) + call psb_gefree(x, base_desc, info) + call psb_gefree(d(0), base_desc, info) + call psb_gefree(d(1), base_desc, info) + end associate 9999 continue call psb_erractionrestore(err_act) if (err_act.eq.psb_act_abort_) then diff --git a/mlprec/impl/mld_dmlprec_aply.f90 b/mlprec/impl/mld_dmlprec_aply.f90 index 3a0010cd..4a046d80 100644 --- a/mlprec/impl/mld_dmlprec_aply.f90 +++ b/mlprec/impl/mld_dmlprec_aply.f90 @@ -251,20 +251,50 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if - ! - ! At first iteration we must use the input BETA - ! - beta_ = beta - level = 1 - - call psb_geaxpby(done,x,dzero,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='geaxbpy') - goto 9999 - end if - - do isweep = 1, p%outer_sweeps - 1 + + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + ! + ! At first iteration we must use the input BETA + ! + beta_ = beta + + + call psb_geaxpby(done,x,dzero,vx2l,base_desc,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='geaxbpy') + goto 9999 + end if + + do isweep = 1, p%outer_sweeps - 1 + ! + ! With the current implementation, y2l is zeroed internally at first smoother. + ! call p%wrk(level)%vy2l%zero() + ! + call inner_ml_aply(level,p,trans_,work,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Inner prec aply') + goto 9999 + end if + call psb_geaxpby(alpha,vy2l,beta_,y,base_desc,info) + ! all iterations after the first must use BETA = 1 + beta_ = done + ! + ! Next iteration should use the current residual to compute a correction + ! + call psb_geaxpby(done,x,dzero,vx2l,base_desc,info) + call psb_spmm(-done,base_a,y,done,vx2l,base_desc,info) + end do + + ! + ! If outer_sweeps == 1 we have just skipped the loop, and it's + ! equivalent to a single application. + ! + ! ! With the current implementation, y2l is zeroed internally at first smoother. ! call p%wrk(level)%vy2l%zero() @@ -276,38 +306,9 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) & a_err='Inner prec aply') goto 9999 end if - call psb_geaxpby(alpha,p%wrk(level)%vy2l,beta_,y,& - & p%precv(level)%base_desc,info) - ! all iterations after the first must use BETA = 1 - beta_ = done - ! - ! Next iteration should use the current residual to compute a correction - ! - call psb_geaxpby(done,x,dzero,p%wrk(level)%vx2l,& - & p%precv(level)%base_desc,info) - call psb_spmm(-done,p%precv(level)%base_a,y,& - & done,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) - end do - - ! - ! If outer_sweeps == 1 we have just skipped the loop, and it's - ! equivalent to a single application. - ! - - ! - ! With the current implementation, y2l is zeroed internally at first smoother. - ! call p%wrk(level)%vy2l%zero() - ! - call inner_ml_aply(level,p,trans_,work,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Inner prec aply') - goto 9999 - end if - call psb_geaxpby(alpha,p%wrk(level)%vy2l,beta_,y,& - & p%precv(level)%base_desc,info) - + call psb_geaxpby(alpha,vy2l,beta_,y,base_desc,info) + + end associate if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error final update') @@ -479,70 +480,75 @@ contains goto 9999 end if - if (allocated(p%precv(level)%sm2a)) then - call psb_geaxpby(done,& - & p%wrk(level)%vx2l,dzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc,info) + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + + if (allocated(p%precv(level)%sm2a)) then + call psb_geaxpby(done,& + & vx2l,dzero,vy2l,& + & base_desc,info) + + sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post) + do k=1, sweeps + call p%precv(level)%sm%apply(done,& + & vy2l,dzero,vty,& + & base_desc, trans,& + & ione,work,info,init='Z') + + call p%precv(level)%sm2a%apply(done,& + & vty,dzero,vy2l,& + & base_desc, trans,& + & ione,work,info,init='Z') + end do - sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post) - do k=1, sweeps + else + sweeps = p%precv(level)%parms%sweeps_pre call p%precv(level)%sm%apply(done,& - & p%wrk(level)%vy2l,dzero,p%wrk(level)%vtx,& - & p%precv(level)%base_desc, trans,& - & ione,work,info,init='Z') - - call p%precv(level)%sm2a%apply(done,& - & p%wrk(level)%vtx,dzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & ione,work,info,init='Z') - end do - - else - sweeps = p%precv(level)%parms%sweeps_pre - call p%precv(level)%sm%apply(done,& - & p%wrk(level)%vx2l,dzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during ADD smoother_apply') - goto 9999 - end if - - if (level < nlev) then - ! Apply the restriction - call psb_map_X2Y(done,p%wrk(level)%vx2l,& - & dzero,p%wrk(level+1)%vx2l,& - & 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 restriction') - goto 9999 + & vx2l,dzero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') end if - - call inner_ml_aply(level+1,p,trans,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') + & a_err='Error during ADD smoother_apply') goto 9999 end if - ! - ! Apply the prolongator - ! - call psb_map_Y2X(done,p%wrk(level+1)%vy2l,& - & done,p%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 (level < nlev) then + ! Apply the restriction + call psb_map_X2Y(done,vx2l,& + & dzero,p%precv(level+1)%wrk%vx2l,& + & 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 restriction') + goto 9999 + end if + + call inner_ml_aply(level+1,p,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 + ! + ! Apply the prolongator + ! + call psb_map_Y2X(done,p%precv(level+1)%wrk%vy2l,& + & done,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 - end if + end if + end associate + call psb_erractionrestore(err_act) return @@ -597,170 +603,174 @@ contains pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) - if (level < nlev) then - ! - ! Apply the first smoother - ! The residual has been prepared before the recursive call. - ! + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + if (level < nlev) then + ! + ! Apply the first smoother + ! The residual has been prepared before the recursive call. + ! - if (pre) then - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & p%wrk(level)%vx2l,dzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') + if (pre) then + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & vx2l,dzero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & vx2l,dzero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during PRE smoother_apply') + goto 9999 + end if + endif + ! + ! Compute the residual and call recursively + ! + if (pre) then + call psb_geaxpby(done,vx2l,& + & dzero,vty,& + & base_desc,info) + + if (info == psb_success_) call psb_spmm(-done,base_a,& + & vy2l,done,vty,& + & base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + call psb_map_X2Y(done,vty,& + & dzero,p%precv(level+1)%wrk%vx2l,& + & 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 restriction') + goto 9999 + end if else - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & p%wrk(level)%vx2l,dzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during PRE smoother_apply') - goto 9999 - end if - endif - ! - ! Compute the residual and call recursively - ! - if (pre) then - call psb_geaxpby(done,p%wrk(level)%vx2l,& - & dzero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - - if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& - & p%wrk(level)%vy2l,done,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - call psb_map_X2Y(done,p%wrk(level)%vty,& - & dzero,p%wrk(level+1)%vx2l,& - & 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 restriction') - goto 9999 - end if - else - ! Shortcut: just transfer x2l. - call psb_map_X2Y(done,p%wrk(level)%vx2l,& - & dzero,p%wrk(level+1)%vx2l,& + ! Shortcut: just transfer x2l. + call psb_map_X2Y(done,vx2l,& + & dzero,p%precv(level+1)%wrk%vx2l,& + & 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 restriction') + goto 9999 + end if + endif + + call inner_ml_aply(level+1,p,trans,work,info) + + ! + ! Apply the prolongator + ! + call psb_map_Y2X(done,p%precv(level+1)%wrk%vy2l,& + & done,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 restriction') + & a_err='Error during prolongation') goto 9999 end if - endif - call inner_ml_aply(level+1,p,trans,work,info) + if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then + + call psb_geaxpby(done,vx2l,& + & dzero,vty,& + & base_desc,info) + if (info == psb_success_) call psb_spmm(-done,base_a,& + & vy2l,done,vty,& + & base_desc,info,work=work,trans=trans) + if (info == psb_success_) call psb_map_X2Y(done,vty,& + & dzero,p%precv(level+1)%wrk%vx2l,& + & 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 W-cycle restriction') + goto 9999 + end if + + call inner_ml_aply(level+1,p,trans,work,info) + + if (info == psb_success_) call psb_map_Y2X(done,p%precv(level+1)%wrk%vy2l,& + & done,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 W recusion/prolongation') + goto 9999 + end if - ! - ! Apply the prolongator - ! - call psb_map_Y2X(done,p%wrk(level+1)%vy2l,& - & done,p%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 + endif - if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then - - call psb_geaxpby(done,p%wrk(level)%vx2l,& - & dzero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& - & p%wrk(level)%vy2l,done,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info == psb_success_) call psb_map_X2Y(done,p%wrk(level)%vty,& - & dzero,p%wrk(level+1)%vx2l,& - & 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 W-cycle restriction') - goto 9999 - end if - - call inner_ml_aply(level+1,p,trans,work,info) - - if (info == psb_success_) call psb_map_Y2X(done,p%wrk(level+1)%vy2l,& - & done,p%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 W recusion/prolongation') - goto 9999 - end if - - endif - - - if (post) then - call psb_geaxpby(done,p%wrk(level)%vx2l,& - & dzero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& - & p%wrk(level)%vy2l,& - & done,p%wrk(level)%vty,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the second smoother - ! - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & p%wrk(level)%vty,done,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - else - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & p%wrk(level)%vty,done,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during POST smoother_apply') - goto 9999 - end if - - endif - - else if (level == nlev) then - - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & p%wrk(level)%vx2l,dzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (post) then + call psb_geaxpby(done,vx2l,& + & dzero,vty,& + & base_desc,info) + if (info == psb_success_) call psb_spmm(-done,base_a,& + & vy2l,& + & done,vty,base_desc,info,& + & work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + + ! + ! Apply the second smoother + ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & vty,done,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & vty,done,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during POST smoother_apply') + goto 9999 + end if - else + endif - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL vs NLEV') - goto 9999 - end if + else if (level == nlev) then + + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & vx2l,dzero,vy2l,& + & base_desc, trans,& + & sweeps,work,info) + else + + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') + goto 9999 + end if + end associate + call psb_erractionrestore(err_act) return @@ -824,147 +834,150 @@ contains !K cycle - if (level == nlev) then - ! - ! Apply smoother - ! - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & p%wrk(level)%vx2l,dzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - - else if (level < nlev) then - - if (trans == 'N') then + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + if (level == nlev) then + ! + ! Apply smoother + ! sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & p%wrk(level)%vx2l,dzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - else - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & p%wrk(level)%vx2l,dzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& + & vx2l,dzero,vy2l,& + & base_desc, trans,& & sweeps,work,info,init='Z') - end if - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-PRE smoother_apply') - goto 9999 - end if - + else if (level < nlev) then - ! - ! Compute the residual and call recursively - ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & vx2l,dzero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & vx2l,dzero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + end if - call psb_geaxpby(done,p%wrk(level)%vx2l,& - & dzero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - - if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& - & p%wrk(level)%vy2l,done,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during 2-PRE smoother_apply') + goto 9999 + end if - ! Apply the restriction - call psb_map_X2Y(done,p%wrk(level)%vty,& - & dzero,p%wrk(level + 1)%vx2l,& - & 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 restriction') - goto 9999 - end if + ! + ! Compute the residual and call recursively + ! - !Set the preconditioner + call psb_geaxpby(done,vx2l,& + & dzero,vty,& + & base_desc,info) - if (level <= nlev - 2 ) then - if (p%precv(level)%parms%ml_cycle == mld_kcyclesym_ml_) then - call mld_dinneritkcycle(p, level + 1, trans, work, 'FCG') - elseif (p%precv(level)%parms%ml_cycle == mld_kcycle_ml_) then - call mld_dinneritkcycle(p, level + 1, trans, work, 'GCR') - else + if (info == psb_success_) call psb_spmm(-done,base_a,& + & vy2l,done,vty,& + & base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Bad value for ml_cycle') + & a_err='Error during residue') goto 9999 + end if + + ! Apply the restriction + call psb_map_X2Y(done,vty,& + & dzero,p%precv(level + 1)%wrk%vx2l,& + & 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 restriction') + goto 9999 + end if + + !Set the preconditioner + + if (level <= nlev - 2 ) then + if (p%precv(level)%parms%ml_cycle == mld_kcyclesym_ml_) then + call mld_dinneritkcycle(p, level + 1, trans, work, 'FCG') + elseif (p%precv(level)%parms%ml_cycle == mld_kcycle_ml_) then + call mld_dinneritkcycle(p, level + 1, trans, work, 'GCR') + else + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Bad value for ml_cycle') + goto 9999 + endif + else + call inner_ml_aply(level + 1 ,p,trans,work,info) endif - else - call inner_ml_aply(level + 1 ,p,trans,work,info) - endif - 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_) 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,p%wrk(level+1)%vy2l,& - & done,p%wrk(level)%vy2l,& - & p%precv(level+1)%map,info,work=work) + ! + ! Apply the prolongator + ! + call psb_map_Y2X(done,p%precv(level+1)%wrk%vy2l,& + & done,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_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during prolongation') + goto 9999 + end if - ! - ! Compute the residual - ! - call psb_geaxpby(done,p%wrk(level)%vx2l,& - & dzero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - call psb_spmm(-done,p%precv(level)%base_a,p%wrk(level)%vy2l,& - & done,p%wrk(level)%vty,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the smoother - ! - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & p%wrk(level)%vty,done,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') + ! + ! Compute the residual + ! + call psb_geaxpby(done,vx2l,& + & dzero,vty,& + & base_desc,info) + call psb_spmm(-done,base_a,vy2l,& + & done,vty,base_desc,info,& + & work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + ! + ! Apply the smoother + ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & vty,done,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & vty,done,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during POST smoother_apply') + goto 9999 + end if else - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & p%wrk(level)%vty,done,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during POST smoother_apply') + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') goto 9999 - end if - else - - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL vs NLEV') - goto 9999 - - endif + endif + end associate call psb_erractionrestore(err_act) return @@ -998,141 +1011,145 @@ contains real(psb_dpk_), allocatable :: temp_v(:) integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx character(len=20) :: name = 'innerit_k_cycle' - - !Assemble rhs, w, v, v1, x - - call psb_geasb(rhs,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - call psb_geasb(w,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - call psb_geasb(v,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - call psb_geasb(v1,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - call psb_geasb(x,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - !Assemble d(0) and d(1) - call psb_geasb(d(0),& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vy2l%v) - call psb_geasb(d(1),& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vy2l%v) - - - call x%zero() - - ! rhs=vx2l and w=rhs - call psb_geaxpby(done,p%wrk(level)%vx2l,dzero,rhs,& - & p%precv(level)%base_desc,info) - call psb_geaxpby(done,p%wrk(level)%vx2l,dzero,w,& - & p%precv(level)%base_desc,info) - - if (psb_errstatus_fatal()) then - nc2l = p%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 - - delta0 = psb_genrm2(w, p%precv(level)%base_desc, info) - - !Apply the preconditioner - call p%wrk(level)%vy2l%zero() - - idx=0 - call inner_ml_aply(level,p,trans,work,info) - - call psb_geaxpby(done,p%wrk(level)%vy2l,dzero,d(idx),p%precv(level)%base_desc,info) - - call psb_spmm(done,p%precv(level)%base_a,d(idx),dzero,v,p%precv(level)%base_desc,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - !FCG - if (psb_toupper(trim(innersolv)) == 'FCG') then - delta_old = psb_gedot(d(idx), w, p%precv(level)%base_desc, info) - tau = psb_gedot(d(idx), v, p%precv(level)%base_desc, info) - !GCR - else if (psb_toupper(trim(innersolv)) == 'GCR') then - delta_old = psb_gedot(v, w, p%precv(level)%base_desc, info) - tau = psb_gedot(v, v, p%precv(level)%base_desc, info) - else - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid inner solver') - goto 9999 - endif - alpha = delta_old/tau - !Update residual w - call psb_geaxpby(-alpha, v, done, w, p%precv(level)%base_desc, info) + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + + !Assemble rhs, w, v, v1, x + + call psb_geasb(rhs,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + call psb_geasb(w,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + call psb_geasb(v,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + call psb_geasb(v1,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + call psb_geasb(x,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + !Assemble d(0) and d(1) + call psb_geasb(d(0),& + & base_desc,info,& + & scratch=.true.,mold=vy2l%v) + call psb_geasb(d(1),& + & base_desc,info,& + & scratch=.true.,mold=vy2l%v) + + + call x%zero() + + ! rhs=vx2l and w=rhs + call psb_geaxpby(done,vx2l,dzero,rhs,& + & base_desc,info) + call psb_geaxpby(done,vx2l,dzero,w,& + & base_desc,info) + + if (psb_errstatus_fatal()) then + nc2l = 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 - l2_norm = psb_genrm2(w, p%precv(level)%base_desc, info) - iter = 0 + delta0 = psb_genrm2(w, base_desc, info) - if (l2_norm <= rtol*delta0) then - !Update solution x - call psb_geaxpby(alpha, d(idx), done, x, p%precv(level)%base_desc, info) - else - iter = iter + 1 - idx=mod(iter,2) + !Apply the preconditioner + call vy2l%zero() - !Apply preconditioner - call psb_geaxpby(done,w,dzero,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) + idx=0 call inner_ml_aply(level,p,trans,work,info) - call psb_geaxpby(done,p%wrk(level)%vy2l,dzero,d(idx),p%precv(level)%base_desc,info) - !Sparse matrix vector product + call psb_geaxpby(done,vy2l,dzero,d(idx),base_desc,info) - call psb_spmm(done,p%precv(level)%base_a,d(idx),dzero,v1,p%precv(level)%base_desc,info) + call psb_spmm(done,base_a,d(idx),dzero,v,base_desc,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') goto 9999 end if - !tau1, tau2, tau3, tau4 + !FCG if (psb_toupper(trim(innersolv)) == 'FCG') then - tau1= psb_gedot(d(idx), v, p%precv(level)%base_desc, info) - tau2= psb_gedot(d(idx), v1, p%precv(level)%base_desc, info) - tau3= psb_gedot(d(idx), w, p%precv(level)%base_desc, info) - tau4= tau2 - (tau1*tau1)/tau + delta_old = psb_gedot(d(idx), w, base_desc, info) + tau = psb_gedot(d(idx), v, base_desc, info) + !GCR else if (psb_toupper(trim(innersolv)) == 'GCR') then - tau1= psb_gedot(v1, v, p%precv(level)%base_desc, info) - tau2= psb_gedot(v1, v1, p%precv(level)%base_desc, info) - tau3= psb_gedot(v1, w, p%precv(level)%base_desc, info) - tau4= tau2 - (tau1*tau1)/tau + delta_old = psb_gedot(v, w, base_desc, info) + tau = psb_gedot(v, v, base_desc, info) else call psb_errpush(psb_err_internal_error_,name,& & a_err='Invalid inner solver') goto 9999 endif - !Update solution - alpha=alpha-(tau1*tau3)/(tau*tau4) - call psb_geaxpby(alpha,d(idx - 1),done,x,p%precv(level)%base_desc,info) - alpha=tau3/tau4 - call psb_geaxpby(alpha,d(idx),done,x,p%precv(level)%base_desc,info) - endif + alpha = delta_old/tau + !Update residual w + call psb_geaxpby(-alpha, v, done, w, base_desc, info) + + l2_norm = psb_genrm2(w, base_desc, info) + iter = 0 + + if (l2_norm <= rtol*delta0) then + !Update solution x + call psb_geaxpby(alpha, d(idx), done, x, base_desc, info) + else + iter = iter + 1 + idx=mod(iter,2) - call psb_geaxpby(done,x,dzero,p%wrk(level)%vy2l,p%precv(level)%base_desc,info) - !Free vectors - call psb_gefree(v, p%precv(level)%base_desc, info) - call psb_gefree(v1, p%precv(level)%base_desc, info) - call psb_gefree(w, p%precv(level)%base_desc, info) - call psb_gefree(x, p%precv(level)%base_desc, info) - call psb_gefree(d(0), p%precv(level)%base_desc, info) - call psb_gefree(d(1), p%precv(level)%base_desc, info) + !Apply preconditioner + call psb_geaxpby(done,w,dzero,vx2l,base_desc,info) + call inner_ml_aply(level,p,trans,work,info) + call psb_geaxpby(done,vy2l,dzero,d(idx),base_desc,info) + + !Sparse matrix vector product + + call psb_spmm(done,base_a,d(idx),dzero,v1,base_desc,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + + !tau1, tau2, tau3, tau4 + if (psb_toupper(trim(innersolv)) == 'FCG') then + tau1= psb_gedot(d(idx), v, base_desc, info) + tau2= psb_gedot(d(idx), v1, base_desc, info) + tau3= psb_gedot(d(idx), w, base_desc, info) + tau4= tau2 - (tau1*tau1)/tau + else if (psb_toupper(trim(innersolv)) == 'GCR') then + tau1= psb_gedot(v1, v, base_desc, info) + tau2= psb_gedot(v1, v1, base_desc, info) + tau3= psb_gedot(v1, w, base_desc, info) + tau4= tau2 - (tau1*tau1)/tau + else + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid inner solver') + goto 9999 + endif + + !Update solution + alpha=alpha-(tau1*tau3)/(tau*tau4) + call psb_geaxpby(alpha,d(idx - 1),done,x,base_desc,info) + alpha=tau3/tau4 + call psb_geaxpby(alpha,d(idx),done,x,base_desc,info) + endif + call psb_geaxpby(done,x,dzero,vy2l,base_desc,info) + !Free vectors + call psb_gefree(v, base_desc, info) + call psb_gefree(v1, base_desc, info) + call psb_gefree(w, base_desc, info) + call psb_gefree(x, base_desc, info) + call psb_gefree(d(0), base_desc, info) + call psb_gefree(d(1), base_desc, info) + end associate 9999 continue call psb_erractionrestore(err_act) if (err_act.eq.psb_act_abort_) then diff --git a/mlprec/impl/mld_smlprec_aply.f90 b/mlprec/impl/mld_smlprec_aply.f90 index 5b1ed296..7ab23307 100644 --- a/mlprec/impl/mld_smlprec_aply.f90 +++ b/mlprec/impl/mld_smlprec_aply.f90 @@ -251,20 +251,50 @@ subroutine mld_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if - ! - ! At first iteration we must use the input BETA - ! - beta_ = beta - level = 1 - - call psb_geaxpby(sone,x,szero,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='geaxbpy') - goto 9999 - end if - - do isweep = 1, p%outer_sweeps - 1 + + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + ! + ! At first iteration we must use the input BETA + ! + beta_ = beta + + + call psb_geaxpby(sone,x,szero,vx2l,base_desc,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='geaxbpy') + goto 9999 + end if + + do isweep = 1, p%outer_sweeps - 1 + ! + ! With the current implementation, y2l is zeroed internally at first smoother. + ! call p%wrk(level)%vy2l%zero() + ! + call inner_ml_aply(level,p,trans_,work,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Inner prec aply') + goto 9999 + end if + call psb_geaxpby(alpha,vy2l,beta_,y,base_desc,info) + ! all iterations after the first must use BETA = 1 + beta_ = sone + ! + ! Next iteration should use the current residual to compute a correction + ! + call psb_geaxpby(sone,x,szero,vx2l,base_desc,info) + call psb_spmm(-sone,base_a,y,sone,vx2l,base_desc,info) + end do + + ! + ! If outer_sweeps == 1 we have just skipped the loop, and it's + ! equivalent to a single application. + ! + ! ! With the current implementation, y2l is zeroed internally at first smoother. ! call p%wrk(level)%vy2l%zero() @@ -276,38 +306,9 @@ subroutine mld_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) & a_err='Inner prec aply') goto 9999 end if - call psb_geaxpby(alpha,p%wrk(level)%vy2l,beta_,y,& - & p%precv(level)%base_desc,info) - ! all iterations after the first must use BETA = 1 - beta_ = sone - ! - ! Next iteration should use the current residual to compute a correction - ! - call psb_geaxpby(sone,x,szero,p%wrk(level)%vx2l,& - & p%precv(level)%base_desc,info) - call psb_spmm(-sone,p%precv(level)%base_a,y,& - & sone,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) - end do - - ! - ! If outer_sweeps == 1 we have just skipped the loop, and it's - ! equivalent to a single application. - ! - - ! - ! With the current implementation, y2l is zeroed internally at first smoother. - ! call p%wrk(level)%vy2l%zero() - ! - call inner_ml_aply(level,p,trans_,work,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Inner prec aply') - goto 9999 - end if - call psb_geaxpby(alpha,p%wrk(level)%vy2l,beta_,y,& - & p%precv(level)%base_desc,info) - + call psb_geaxpby(alpha,vy2l,beta_,y,base_desc,info) + + end associate if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error final update') @@ -479,70 +480,75 @@ contains goto 9999 end if - if (allocated(p%precv(level)%sm2a)) then - call psb_geaxpby(sone,& - & p%wrk(level)%vx2l,szero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc,info) + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + + if (allocated(p%precv(level)%sm2a)) then + call psb_geaxpby(sone,& + & vx2l,szero,vy2l,& + & base_desc,info) + + sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post) + do k=1, sweeps + call p%precv(level)%sm%apply(sone,& + & vy2l,szero,vty,& + & base_desc, trans,& + & ione,work,info,init='Z') + + call p%precv(level)%sm2a%apply(sone,& + & vty,szero,vy2l,& + & base_desc, trans,& + & ione,work,info,init='Z') + end do - sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post) - do k=1, sweeps + else + sweeps = p%precv(level)%parms%sweeps_pre call p%precv(level)%sm%apply(sone,& - & p%wrk(level)%vy2l,szero,p%wrk(level)%vtx,& - & p%precv(level)%base_desc, trans,& - & ione,work,info,init='Z') - - call p%precv(level)%sm2a%apply(sone,& - & p%wrk(level)%vtx,szero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & ione,work,info,init='Z') - end do - - else - sweeps = p%precv(level)%parms%sweeps_pre - call p%precv(level)%sm%apply(sone,& - & p%wrk(level)%vx2l,szero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during ADD smoother_apply') - goto 9999 - end if - - if (level < nlev) then - ! Apply the restriction - call psb_map_X2Y(sone,p%wrk(level)%vx2l,& - & szero,p%wrk(level+1)%vx2l,& - & 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 restriction') - goto 9999 + & vx2l,szero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') end if - - call inner_ml_aply(level+1,p,trans,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') + & a_err='Error during ADD smoother_apply') goto 9999 end if - ! - ! Apply the prolongator - ! - call psb_map_Y2X(sone,p%wrk(level+1)%vy2l,& - & sone,p%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 (level < nlev) then + ! Apply the restriction + call psb_map_X2Y(sone,vx2l,& + & szero,p%precv(level+1)%wrk%vx2l,& + & 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 restriction') + goto 9999 + end if + + call inner_ml_aply(level+1,p,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 + ! + ! Apply the prolongator + ! + call psb_map_Y2X(sone,p%precv(level+1)%wrk%vy2l,& + & sone,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 - end if + end if + end associate + call psb_erractionrestore(err_act) return @@ -597,170 +603,174 @@ contains pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) - if (level < nlev) then - ! - ! Apply the first smoother - ! The residual has been prepared before the recursive call. - ! + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + if (level < nlev) then + ! + ! Apply the first smoother + ! The residual has been prepared before the recursive call. + ! - if (pre) then - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & p%wrk(level)%vx2l,szero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') + if (pre) then + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & vx2l,szero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& + & vx2l,szero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during PRE smoother_apply') + goto 9999 + end if + endif + ! + ! Compute the residual and call recursively + ! + if (pre) then + call psb_geaxpby(sone,vx2l,& + & szero,vty,& + & base_desc,info) + + if (info == psb_success_) call psb_spmm(-sone,base_a,& + & vy2l,sone,vty,& + & base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + call psb_map_X2Y(sone,vty,& + & szero,p%precv(level+1)%wrk%vx2l,& + & 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 restriction') + goto 9999 + end if else - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& - & p%wrk(level)%vx2l,szero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during PRE smoother_apply') - goto 9999 - end if - endif - ! - ! Compute the residual and call recursively - ! - if (pre) then - call psb_geaxpby(sone,p%wrk(level)%vx2l,& - & szero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - - if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& - & p%wrk(level)%vy2l,sone,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - call psb_map_X2Y(sone,p%wrk(level)%vty,& - & szero,p%wrk(level+1)%vx2l,& - & 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 restriction') - goto 9999 - end if - else - ! Shortcut: just transfer x2l. - call psb_map_X2Y(sone,p%wrk(level)%vx2l,& - & szero,p%wrk(level+1)%vx2l,& + ! Shortcut: just transfer x2l. + call psb_map_X2Y(sone,vx2l,& + & szero,p%precv(level+1)%wrk%vx2l,& + & 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 restriction') + goto 9999 + end if + endif + + call inner_ml_aply(level+1,p,trans,work,info) + + ! + ! Apply the prolongator + ! + call psb_map_Y2X(sone,p%precv(level+1)%wrk%vy2l,& + & sone,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 restriction') + & a_err='Error during prolongation') goto 9999 end if - endif - call inner_ml_aply(level+1,p,trans,work,info) + if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then + + call psb_geaxpby(sone,vx2l,& + & szero,vty,& + & base_desc,info) + if (info == psb_success_) call psb_spmm(-sone,base_a,& + & vy2l,sone,vty,& + & base_desc,info,work=work,trans=trans) + if (info == psb_success_) call psb_map_X2Y(sone,vty,& + & szero,p%precv(level+1)%wrk%vx2l,& + & 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 W-cycle restriction') + goto 9999 + end if + + call inner_ml_aply(level+1,p,trans,work,info) + + if (info == psb_success_) call psb_map_Y2X(sone,p%precv(level+1)%wrk%vy2l,& + & sone,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 W recusion/prolongation') + goto 9999 + end if - ! - ! Apply the prolongator - ! - call psb_map_Y2X(sone,p%wrk(level+1)%vy2l,& - & sone,p%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 + endif - if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then - - call psb_geaxpby(sone,p%wrk(level)%vx2l,& - & szero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& - & p%wrk(level)%vy2l,sone,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info == psb_success_) call psb_map_X2Y(sone,p%wrk(level)%vty,& - & szero,p%wrk(level+1)%vx2l,& - & 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 W-cycle restriction') - goto 9999 - end if - - call inner_ml_aply(level+1,p,trans,work,info) - - if (info == psb_success_) call psb_map_Y2X(sone,p%wrk(level+1)%vy2l,& - & sone,p%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 W recusion/prolongation') - goto 9999 - end if - - endif - - - if (post) then - call psb_geaxpby(sone,p%wrk(level)%vx2l,& - & szero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& - & p%wrk(level)%vy2l,& - & sone,p%wrk(level)%vty,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the second smoother - ! - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& - & p%wrk(level)%vty,sone,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - else - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & p%wrk(level)%vty,sone,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during POST smoother_apply') - goto 9999 - end if - - endif - - else if (level == nlev) then - - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & p%wrk(level)%vx2l,szero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (post) then + call psb_geaxpby(sone,vx2l,& + & szero,vty,& + & base_desc,info) + if (info == psb_success_) call psb_spmm(-sone,base_a,& + & vy2l,& + & sone,vty,base_desc,info,& + & work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + + ! + ! Apply the second smoother + ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& + & vty,sone,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & vty,sone,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during POST smoother_apply') + goto 9999 + end if - else + endif - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL vs NLEV') - goto 9999 - end if + else if (level == nlev) then + + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & vx2l,szero,vy2l,& + & base_desc, trans,& + & sweeps,work,info) + else + + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') + goto 9999 + end if + end associate + call psb_erractionrestore(err_act) return @@ -824,147 +834,150 @@ contains !K cycle - if (level == nlev) then - ! - ! Apply smoother - ! - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & p%wrk(level)%vx2l,szero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - - else if (level < nlev) then - - if (trans == 'N') then + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + if (level == nlev) then + ! + ! Apply smoother + ! sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & p%wrk(level)%vx2l,szero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - else - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& - & p%wrk(level)%vx2l,szero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& + & vx2l,szero,vy2l,& + & base_desc, trans,& & sweeps,work,info,init='Z') - end if - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-PRE smoother_apply') - goto 9999 - end if - + else if (level < nlev) then - ! - ! Compute the residual and call recursively - ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & vx2l,szero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& + & vx2l,szero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + end if - call psb_geaxpby(sone,p%wrk(level)%vx2l,& - & szero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - - if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& - & p%wrk(level)%vy2l,sone,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during 2-PRE smoother_apply') + goto 9999 + end if - ! Apply the restriction - call psb_map_X2Y(sone,p%wrk(level)%vty,& - & szero,p%wrk(level + 1)%vx2l,& - & 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 restriction') - goto 9999 - end if + ! + ! Compute the residual and call recursively + ! - !Set the preconditioner + call psb_geaxpby(sone,vx2l,& + & szero,vty,& + & base_desc,info) - if (level <= nlev - 2 ) then - if (p%precv(level)%parms%ml_cycle == mld_kcyclesym_ml_) then - call mld_sinneritkcycle(p, level + 1, trans, work, 'FCG') - elseif (p%precv(level)%parms%ml_cycle == mld_kcycle_ml_) then - call mld_sinneritkcycle(p, level + 1, trans, work, 'GCR') - else + if (info == psb_success_) call psb_spmm(-sone,base_a,& + & vy2l,sone,vty,& + & base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Bad value for ml_cycle') + & a_err='Error during residue') goto 9999 + end if + + ! Apply the restriction + call psb_map_X2Y(sone,vty,& + & szero,p%precv(level + 1)%wrk%vx2l,& + & 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 restriction') + goto 9999 + end if + + !Set the preconditioner + + if (level <= nlev - 2 ) then + if (p%precv(level)%parms%ml_cycle == mld_kcyclesym_ml_) then + call mld_sinneritkcycle(p, level + 1, trans, work, 'FCG') + elseif (p%precv(level)%parms%ml_cycle == mld_kcycle_ml_) then + call mld_sinneritkcycle(p, level + 1, trans, work, 'GCR') + else + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Bad value for ml_cycle') + goto 9999 + endif + else + call inner_ml_aply(level + 1 ,p,trans,work,info) endif - else - call inner_ml_aply(level + 1 ,p,trans,work,info) - endif - 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_) 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,p%wrk(level+1)%vy2l,& - & sone,p%wrk(level)%vy2l,& - & p%precv(level+1)%map,info,work=work) + ! + ! Apply the prolongator + ! + call psb_map_Y2X(sone,p%precv(level+1)%wrk%vy2l,& + & sone,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_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during prolongation') + goto 9999 + end if - ! - ! Compute the residual - ! - call psb_geaxpby(sone,p%wrk(level)%vx2l,& - & szero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - call psb_spmm(-sone,p%precv(level)%base_a,p%wrk(level)%vy2l,& - & sone,p%wrk(level)%vty,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the smoother - ! - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& - & p%wrk(level)%vty,sone,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') + ! + ! Compute the residual + ! + call psb_geaxpby(sone,vx2l,& + & szero,vty,& + & base_desc,info) + call psb_spmm(-sone,base_a,vy2l,& + & sone,vty,base_desc,info,& + & work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + ! + ! Apply the smoother + ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& + & vty,sone,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & vty,sone,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during POST smoother_apply') + goto 9999 + end if else - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & p%wrk(level)%vty,sone,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during POST smoother_apply') + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') goto 9999 - end if - else - - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL vs NLEV') - goto 9999 - - endif + endif + end associate call psb_erractionrestore(err_act) return @@ -998,141 +1011,145 @@ contains real(psb_spk_), allocatable :: temp_v(:) integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx character(len=20) :: name = 'innerit_k_cycle' - - !Assemble rhs, w, v, v1, x - - call psb_geasb(rhs,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - call psb_geasb(w,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - call psb_geasb(v,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - call psb_geasb(v1,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - call psb_geasb(x,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - !Assemble d(0) and d(1) - call psb_geasb(d(0),& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vy2l%v) - call psb_geasb(d(1),& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vy2l%v) - - - call x%zero() - - ! rhs=vx2l and w=rhs - call psb_geaxpby(sone,p%wrk(level)%vx2l,szero,rhs,& - & p%precv(level)%base_desc,info) - call psb_geaxpby(sone,p%wrk(level)%vx2l,szero,w,& - & p%precv(level)%base_desc,info) - - if (psb_errstatus_fatal()) then - nc2l = p%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 - - delta0 = psb_genrm2(w, p%precv(level)%base_desc, info) - - !Apply the preconditioner - call p%wrk(level)%vy2l%zero() - - idx=0 - call inner_ml_aply(level,p,trans,work,info) - - call psb_geaxpby(sone,p%wrk(level)%vy2l,szero,d(idx),p%precv(level)%base_desc,info) - - call psb_spmm(sone,p%precv(level)%base_a,d(idx),szero,v,p%precv(level)%base_desc,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - !FCG - if (psb_toupper(trim(innersolv)) == 'FCG') then - delta_old = psb_gedot(d(idx), w, p%precv(level)%base_desc, info) - tau = psb_gedot(d(idx), v, p%precv(level)%base_desc, info) - !GCR - else if (psb_toupper(trim(innersolv)) == 'GCR') then - delta_old = psb_gedot(v, w, p%precv(level)%base_desc, info) - tau = psb_gedot(v, v, p%precv(level)%base_desc, info) - else - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid inner solver') - goto 9999 - endif - alpha = delta_old/tau - !Update residual w - call psb_geaxpby(-alpha, v, sone, w, p%precv(level)%base_desc, info) + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + + !Assemble rhs, w, v, v1, x + + call psb_geasb(rhs,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + call psb_geasb(w,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + call psb_geasb(v,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + call psb_geasb(v1,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + call psb_geasb(x,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + !Assemble d(0) and d(1) + call psb_geasb(d(0),& + & base_desc,info,& + & scratch=.true.,mold=vy2l%v) + call psb_geasb(d(1),& + & base_desc,info,& + & scratch=.true.,mold=vy2l%v) + + + call x%zero() + + ! rhs=vx2l and w=rhs + call psb_geaxpby(sone,vx2l,szero,rhs,& + & base_desc,info) + call psb_geaxpby(sone,vx2l,szero,w,& + & base_desc,info) + + if (psb_errstatus_fatal()) then + nc2l = 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 - l2_norm = psb_genrm2(w, p%precv(level)%base_desc, info) - iter = 0 + delta0 = psb_genrm2(w, base_desc, info) - if (l2_norm <= rtol*delta0) then - !Update solution x - call psb_geaxpby(alpha, d(idx), sone, x, p%precv(level)%base_desc, info) - else - iter = iter + 1 - idx=mod(iter,2) + !Apply the preconditioner + call vy2l%zero() - !Apply preconditioner - call psb_geaxpby(sone,w,szero,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) + idx=0 call inner_ml_aply(level,p,trans,work,info) - call psb_geaxpby(sone,p%wrk(level)%vy2l,szero,d(idx),p%precv(level)%base_desc,info) - !Sparse matrix vector product + call psb_geaxpby(sone,vy2l,szero,d(idx),base_desc,info) - call psb_spmm(sone,p%precv(level)%base_a,d(idx),szero,v1,p%precv(level)%base_desc,info) + call psb_spmm(sone,base_a,d(idx),szero,v,base_desc,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') goto 9999 end if - !tau1, tau2, tau3, tau4 + !FCG if (psb_toupper(trim(innersolv)) == 'FCG') then - tau1= psb_gedot(d(idx), v, p%precv(level)%base_desc, info) - tau2= psb_gedot(d(idx), v1, p%precv(level)%base_desc, info) - tau3= psb_gedot(d(idx), w, p%precv(level)%base_desc, info) - tau4= tau2 - (tau1*tau1)/tau + delta_old = psb_gedot(d(idx), w, base_desc, info) + tau = psb_gedot(d(idx), v, base_desc, info) + !GCR else if (psb_toupper(trim(innersolv)) == 'GCR') then - tau1= psb_gedot(v1, v, p%precv(level)%base_desc, info) - tau2= psb_gedot(v1, v1, p%precv(level)%base_desc, info) - tau3= psb_gedot(v1, w, p%precv(level)%base_desc, info) - tau4= tau2 - (tau1*tau1)/tau + delta_old = psb_gedot(v, w, base_desc, info) + tau = psb_gedot(v, v, base_desc, info) else call psb_errpush(psb_err_internal_error_,name,& & a_err='Invalid inner solver') goto 9999 endif - !Update solution - alpha=alpha-(tau1*tau3)/(tau*tau4) - call psb_geaxpby(alpha,d(idx - 1),sone,x,p%precv(level)%base_desc,info) - alpha=tau3/tau4 - call psb_geaxpby(alpha,d(idx),sone,x,p%precv(level)%base_desc,info) - endif + alpha = delta_old/tau + !Update residual w + call psb_geaxpby(-alpha, v, sone, w, base_desc, info) + + l2_norm = psb_genrm2(w, base_desc, info) + iter = 0 + + if (l2_norm <= rtol*delta0) then + !Update solution x + call psb_geaxpby(alpha, d(idx), sone, x, base_desc, info) + else + iter = iter + 1 + idx=mod(iter,2) - call psb_geaxpby(sone,x,szero,p%wrk(level)%vy2l,p%precv(level)%base_desc,info) - !Free vectors - call psb_gefree(v, p%precv(level)%base_desc, info) - call psb_gefree(v1, p%precv(level)%base_desc, info) - call psb_gefree(w, p%precv(level)%base_desc, info) - call psb_gefree(x, p%precv(level)%base_desc, info) - call psb_gefree(d(0), p%precv(level)%base_desc, info) - call psb_gefree(d(1), p%precv(level)%base_desc, info) + !Apply preconditioner + call psb_geaxpby(sone,w,szero,vx2l,base_desc,info) + call inner_ml_aply(level,p,trans,work,info) + call psb_geaxpby(sone,vy2l,szero,d(idx),base_desc,info) + + !Sparse matrix vector product + + call psb_spmm(sone,base_a,d(idx),szero,v1,base_desc,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + + !tau1, tau2, tau3, tau4 + if (psb_toupper(trim(innersolv)) == 'FCG') then + tau1= psb_gedot(d(idx), v, base_desc, info) + tau2= psb_gedot(d(idx), v1, base_desc, info) + tau3= psb_gedot(d(idx), w, base_desc, info) + tau4= tau2 - (tau1*tau1)/tau + else if (psb_toupper(trim(innersolv)) == 'GCR') then + tau1= psb_gedot(v1, v, base_desc, info) + tau2= psb_gedot(v1, v1, base_desc, info) + tau3= psb_gedot(v1, w, base_desc, info) + tau4= tau2 - (tau1*tau1)/tau + else + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid inner solver') + goto 9999 + endif + + !Update solution + alpha=alpha-(tau1*tau3)/(tau*tau4) + call psb_geaxpby(alpha,d(idx - 1),sone,x,base_desc,info) + alpha=tau3/tau4 + call psb_geaxpby(alpha,d(idx),sone,x,base_desc,info) + endif + call psb_geaxpby(sone,x,szero,vy2l,base_desc,info) + !Free vectors + call psb_gefree(v, base_desc, info) + call psb_gefree(v1, base_desc, info) + call psb_gefree(w, base_desc, info) + call psb_gefree(x, base_desc, info) + call psb_gefree(d(0), base_desc, info) + call psb_gefree(d(1), base_desc, info) + end associate 9999 continue call psb_erractionrestore(err_act) if (err_act.eq.psb_act_abort_) then diff --git a/mlprec/impl/mld_zmlprec_aply.f90 b/mlprec/impl/mld_zmlprec_aply.f90 index bf7d7e48..372b6835 100644 --- a/mlprec/impl/mld_zmlprec_aply.f90 +++ b/mlprec/impl/mld_zmlprec_aply.f90 @@ -251,20 +251,50 @@ subroutine mld_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if - ! - ! At first iteration we must use the input BETA - ! - beta_ = beta - level = 1 - - call psb_geaxpby(zone,x,zzero,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='geaxbpy') - goto 9999 - end if - - do isweep = 1, p%outer_sweeps - 1 + + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + ! + ! At first iteration we must use the input BETA + ! + beta_ = beta + + + call psb_geaxpby(zone,x,zzero,vx2l,base_desc,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='geaxbpy') + goto 9999 + end if + + do isweep = 1, p%outer_sweeps - 1 + ! + ! With the current implementation, y2l is zeroed internally at first smoother. + ! call p%wrk(level)%vy2l%zero() + ! + call inner_ml_aply(level,p,trans_,work,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Inner prec aply') + goto 9999 + end if + call psb_geaxpby(alpha,vy2l,beta_,y,base_desc,info) + ! all iterations after the first must use BETA = 1 + beta_ = zone + ! + ! Next iteration should use the current residual to compute a correction + ! + call psb_geaxpby(zone,x,zzero,vx2l,base_desc,info) + call psb_spmm(-zone,base_a,y,zone,vx2l,base_desc,info) + end do + + ! + ! If outer_sweeps == 1 we have just skipped the loop, and it's + ! equivalent to a single application. + ! + ! ! With the current implementation, y2l is zeroed internally at first smoother. ! call p%wrk(level)%vy2l%zero() @@ -276,38 +306,9 @@ subroutine mld_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) & a_err='Inner prec aply') goto 9999 end if - call psb_geaxpby(alpha,p%wrk(level)%vy2l,beta_,y,& - & p%precv(level)%base_desc,info) - ! all iterations after the first must use BETA = 1 - beta_ = zone - ! - ! Next iteration should use the current residual to compute a correction - ! - call psb_geaxpby(zone,x,zzero,p%wrk(level)%vx2l,& - & p%precv(level)%base_desc,info) - call psb_spmm(-zone,p%precv(level)%base_a,y,& - & zone,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) - end do - - ! - ! If outer_sweeps == 1 we have just skipped the loop, and it's - ! equivalent to a single application. - ! - - ! - ! With the current implementation, y2l is zeroed internally at first smoother. - ! call p%wrk(level)%vy2l%zero() - ! - call inner_ml_aply(level,p,trans_,work,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Inner prec aply') - goto 9999 - end if - call psb_geaxpby(alpha,p%wrk(level)%vy2l,beta_,y,& - & p%precv(level)%base_desc,info) - + call psb_geaxpby(alpha,vy2l,beta_,y,base_desc,info) + + end associate if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error final update') @@ -479,70 +480,75 @@ contains goto 9999 end if - if (allocated(p%precv(level)%sm2a)) then - call psb_geaxpby(zone,& - & p%wrk(level)%vx2l,zzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc,info) + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + + if (allocated(p%precv(level)%sm2a)) then + call psb_geaxpby(zone,& + & vx2l,zzero,vy2l,& + & base_desc,info) + + sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post) + do k=1, sweeps + call p%precv(level)%sm%apply(zone,& + & vy2l,zzero,vty,& + & base_desc, trans,& + & ione,work,info,init='Z') + + call p%precv(level)%sm2a%apply(zone,& + & vty,zzero,vy2l,& + & base_desc, trans,& + & ione,work,info,init='Z') + end do - sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post) - do k=1, sweeps + else + sweeps = p%precv(level)%parms%sweeps_pre call p%precv(level)%sm%apply(zone,& - & p%wrk(level)%vy2l,zzero,p%wrk(level)%vtx,& - & p%precv(level)%base_desc, trans,& - & ione,work,info,init='Z') - - call p%precv(level)%sm2a%apply(zone,& - & p%wrk(level)%vtx,zzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & ione,work,info,init='Z') - end do - - else - sweeps = p%precv(level)%parms%sweeps_pre - call p%precv(level)%sm%apply(zone,& - & p%wrk(level)%vx2l,zzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during ADD smoother_apply') - goto 9999 - end if - - if (level < nlev) then - ! Apply the restriction - call psb_map_X2Y(zone,p%wrk(level)%vx2l,& - & zzero,p%wrk(level+1)%vx2l,& - & 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 restriction') - goto 9999 + & vx2l,zzero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') end if - - call inner_ml_aply(level+1,p,trans,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') + & a_err='Error during ADD smoother_apply') goto 9999 end if - ! - ! Apply the prolongator - ! - call psb_map_Y2X(zone,p%wrk(level+1)%vy2l,& - & zone,p%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 (level < nlev) then + ! Apply the restriction + call psb_map_X2Y(zone,vx2l,& + & zzero,p%precv(level+1)%wrk%vx2l,& + & 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 restriction') + goto 9999 + end if + + call inner_ml_aply(level+1,p,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 + ! + ! Apply the prolongator + ! + call psb_map_Y2X(zone,p%precv(level+1)%wrk%vy2l,& + & zone,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 - end if + end if + end associate + call psb_erractionrestore(err_act) return @@ -597,170 +603,174 @@ contains pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) - if (level < nlev) then - ! - ! Apply the first smoother - ! The residual has been prepared before the recursive call. - ! + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + if (level < nlev) then + ! + ! Apply the first smoother + ! The residual has been prepared before the recursive call. + ! - if (pre) then - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & p%wrk(level)%vx2l,zzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') + if (pre) then + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & vx2l,zzero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& + & vx2l,zzero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during PRE smoother_apply') + goto 9999 + end if + endif + ! + ! Compute the residual and call recursively + ! + if (pre) then + call psb_geaxpby(zone,vx2l,& + & zzero,vty,& + & base_desc,info) + + if (info == psb_success_) call psb_spmm(-zone,base_a,& + & vy2l,zone,vty,& + & base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + call psb_map_X2Y(zone,vty,& + & zzero,p%precv(level+1)%wrk%vx2l,& + & 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 restriction') + goto 9999 + end if else - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& - & p%wrk(level)%vx2l,zzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during PRE smoother_apply') - goto 9999 - end if - endif - ! - ! Compute the residual and call recursively - ! - if (pre) then - call psb_geaxpby(zone,p%wrk(level)%vx2l,& - & zzero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - - if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& - & p%wrk(level)%vy2l,zone,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - call psb_map_X2Y(zone,p%wrk(level)%vty,& - & zzero,p%wrk(level+1)%vx2l,& - & 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 restriction') - goto 9999 - end if - else - ! Shortcut: just transfer x2l. - call psb_map_X2Y(zone,p%wrk(level)%vx2l,& - & zzero,p%wrk(level+1)%vx2l,& + ! Shortcut: just transfer x2l. + call psb_map_X2Y(zone,vx2l,& + & zzero,p%precv(level+1)%wrk%vx2l,& + & 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 restriction') + goto 9999 + end if + endif + + call inner_ml_aply(level+1,p,trans,work,info) + + ! + ! Apply the prolongator + ! + call psb_map_Y2X(zone,p%precv(level+1)%wrk%vy2l,& + & zone,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 restriction') + & a_err='Error during prolongation') goto 9999 end if - endif - call inner_ml_aply(level+1,p,trans,work,info) + if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then + + call psb_geaxpby(zone,vx2l,& + & zzero,vty,& + & base_desc,info) + if (info == psb_success_) call psb_spmm(-zone,base_a,& + & vy2l,zone,vty,& + & base_desc,info,work=work,trans=trans) + if (info == psb_success_) call psb_map_X2Y(zone,vty,& + & zzero,p%precv(level+1)%wrk%vx2l,& + & 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 W-cycle restriction') + goto 9999 + end if + + call inner_ml_aply(level+1,p,trans,work,info) + + if (info == psb_success_) call psb_map_Y2X(zone,p%precv(level+1)%wrk%vy2l,& + & zone,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 W recusion/prolongation') + goto 9999 + end if - ! - ! Apply the prolongator - ! - call psb_map_Y2X(zone,p%wrk(level+1)%vy2l,& - & zone,p%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 + endif - if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then - - call psb_geaxpby(zone,p%wrk(level)%vx2l,& - & zzero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& - & p%wrk(level)%vy2l,zone,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info == psb_success_) call psb_map_X2Y(zone,p%wrk(level)%vty,& - & zzero,p%wrk(level+1)%vx2l,& - & 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 W-cycle restriction') - goto 9999 - end if - - call inner_ml_aply(level+1,p,trans,work,info) - - if (info == psb_success_) call psb_map_Y2X(zone,p%wrk(level+1)%vy2l,& - & zone,p%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 W recusion/prolongation') - goto 9999 - end if - - endif - - - if (post) then - call psb_geaxpby(zone,p%wrk(level)%vx2l,& - & zzero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& - & p%wrk(level)%vy2l,& - & zone,p%wrk(level)%vty,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the second smoother - ! - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& - & p%wrk(level)%vty,zone,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - else - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & p%wrk(level)%vty,zone,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during POST smoother_apply') - goto 9999 - end if - - endif - - else if (level == nlev) then - - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & p%wrk(level)%vx2l,zzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (post) then + call psb_geaxpby(zone,vx2l,& + & zzero,vty,& + & base_desc,info) + if (info == psb_success_) call psb_spmm(-zone,base_a,& + & vy2l,& + & zone,vty,base_desc,info,& + & work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + + ! + ! Apply the second smoother + ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& + & vty,zone,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & vty,zone,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during POST smoother_apply') + goto 9999 + end if - else + endif - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL vs NLEV') - goto 9999 - end if + else if (level == nlev) then + + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & vx2l,zzero,vy2l,& + & base_desc, trans,& + & sweeps,work,info) + else + + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') + goto 9999 + end if + end associate + call psb_erractionrestore(err_act) return @@ -824,147 +834,150 @@ contains !K cycle - if (level == nlev) then - ! - ! Apply smoother - ! - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & p%wrk(level)%vx2l,zzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - - else if (level < nlev) then - - if (trans == 'N') then + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + if (level == nlev) then + ! + ! Apply smoother + ! sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & p%wrk(level)%vx2l,zzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - else - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& - & p%wrk(level)%vx2l,zzero,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& + & vx2l,zzero,vy2l,& + & base_desc, trans,& & sweeps,work,info,init='Z') - end if - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-PRE smoother_apply') - goto 9999 - end if - + else if (level < nlev) then - ! - ! Compute the residual and call recursively - ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & vx2l,zzero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& + & vx2l,zzero,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + end if - call psb_geaxpby(zone,p%wrk(level)%vx2l,& - & zzero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - - if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& - & p%wrk(level)%vy2l,zone,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during 2-PRE smoother_apply') + goto 9999 + end if - ! Apply the restriction - call psb_map_X2Y(zone,p%wrk(level)%vty,& - & zzero,p%wrk(level + 1)%vx2l,& - & 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 restriction') - goto 9999 - end if + ! + ! Compute the residual and call recursively + ! - !Set the preconditioner + call psb_geaxpby(zone,vx2l,& + & zzero,vty,& + & base_desc,info) - if (level <= nlev - 2 ) then - if (p%precv(level)%parms%ml_cycle == mld_kcyclesym_ml_) then - call mld_zinneritkcycle(p, level + 1, trans, work, 'FCG') - elseif (p%precv(level)%parms%ml_cycle == mld_kcycle_ml_) then - call mld_zinneritkcycle(p, level + 1, trans, work, 'GCR') - else + if (info == psb_success_) call psb_spmm(-zone,base_a,& + & vy2l,zone,vty,& + & base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Bad value for ml_cycle') + & a_err='Error during residue') goto 9999 + end if + + ! Apply the restriction + call psb_map_X2Y(zone,vty,& + & zzero,p%precv(level + 1)%wrk%vx2l,& + & 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 restriction') + goto 9999 + end if + + !Set the preconditioner + + if (level <= nlev - 2 ) then + if (p%precv(level)%parms%ml_cycle == mld_kcyclesym_ml_) then + call mld_zinneritkcycle(p, level + 1, trans, work, 'FCG') + elseif (p%precv(level)%parms%ml_cycle == mld_kcycle_ml_) then + call mld_zinneritkcycle(p, level + 1, trans, work, 'GCR') + else + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Bad value for ml_cycle') + goto 9999 + endif + else + call inner_ml_aply(level + 1 ,p,trans,work,info) endif - else - call inner_ml_aply(level + 1 ,p,trans,work,info) - endif - 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_) 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,p%wrk(level+1)%vy2l,& - & zone,p%wrk(level)%vy2l,& - & p%precv(level+1)%map,info,work=work) + ! + ! Apply the prolongator + ! + call psb_map_Y2X(zone,p%precv(level+1)%wrk%vy2l,& + & zone,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_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during prolongation') + goto 9999 + end if - ! - ! Compute the residual - ! - call psb_geaxpby(zone,p%wrk(level)%vx2l,& - & zzero,p%wrk(level)%vty,& - & p%precv(level)%base_desc,info) - call psb_spmm(-zone,p%precv(level)%base_a,p%wrk(level)%vy2l,& - & zone,p%wrk(level)%vty,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the smoother - ! - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& - & p%wrk(level)%vty,zone,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') + ! + ! Compute the residual + ! + call psb_geaxpby(zone,vx2l,& + & zzero,vty,& + & base_desc,info) + call psb_spmm(-zone,base_a,vy2l,& + & zone,vty,base_desc,info,& + & work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + ! + ! Apply the smoother + ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& + & vty,zone,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & vty,zone,vy2l,& + & base_desc, trans,& + & sweeps,work,info,init='Z') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during POST smoother_apply') + goto 9999 + end if else - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & p%wrk(level)%vty,zone,p%wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during POST smoother_apply') + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') goto 9999 - end if - else - - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL vs NLEV') - goto 9999 - - endif + endif + end associate call psb_erractionrestore(err_act) return @@ -998,141 +1011,145 @@ contains complex(psb_dpk_), allocatable :: temp_v(:) integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx character(len=20) :: name = 'innerit_k_cycle' - - !Assemble rhs, w, v, v1, x - - call psb_geasb(rhs,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - call psb_geasb(w,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - call psb_geasb(v,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - call psb_geasb(v1,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - call psb_geasb(x,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vx2l%v) - !Assemble d(0) and d(1) - call psb_geasb(d(0),& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vy2l%v) - call psb_geasb(d(1),& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=p%wrk(level)%vy2l%v) - - - call x%zero() - - ! rhs=vx2l and w=rhs - call psb_geaxpby(zone,p%wrk(level)%vx2l,zzero,rhs,& - & p%precv(level)%base_desc,info) - call psb_geaxpby(zone,p%wrk(level)%vx2l,zzero,w,& - & p%precv(level)%base_desc,info) - - if (psb_errstatus_fatal()) then - nc2l = p%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 - - delta0 = psb_genrm2(w, p%precv(level)%base_desc, info) - - !Apply the preconditioner - call p%wrk(level)%vy2l%zero() - - idx=0 - call inner_ml_aply(level,p,trans,work,info) - - call psb_geaxpby(zone,p%wrk(level)%vy2l,zzero,d(idx),p%precv(level)%base_desc,info) - - call psb_spmm(zone,p%precv(level)%base_a,d(idx),zzero,v,p%precv(level)%base_desc,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - !FCG - if (psb_toupper(trim(innersolv)) == 'FCG') then - delta_old = psb_gedot(d(idx), w, p%precv(level)%base_desc, info) - tau = psb_gedot(d(idx), v, p%precv(level)%base_desc, info) - !GCR - else if (psb_toupper(trim(innersolv)) == 'GCR') then - delta_old = psb_gedot(v, w, p%precv(level)%base_desc, info) - tau = psb_gedot(v, v, p%precv(level)%base_desc, info) - else - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid inner solver') - goto 9999 - endif - alpha = delta_old/tau - !Update residual w - call psb_geaxpby(-alpha, v, zone, w, p%precv(level)%base_desc, info) + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& + & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + + !Assemble rhs, w, v, v1, x + + call psb_geasb(rhs,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + call psb_geasb(w,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + call psb_geasb(v,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + call psb_geasb(v1,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + call psb_geasb(x,& + & base_desc,info,& + & scratch=.true.,mold=vx2l%v) + !Assemble d(0) and d(1) + call psb_geasb(d(0),& + & base_desc,info,& + & scratch=.true.,mold=vy2l%v) + call psb_geasb(d(1),& + & base_desc,info,& + & scratch=.true.,mold=vy2l%v) + + + call x%zero() + + ! rhs=vx2l and w=rhs + call psb_geaxpby(zone,vx2l,zzero,rhs,& + & base_desc,info) + call psb_geaxpby(zone,vx2l,zzero,w,& + & base_desc,info) + + if (psb_errstatus_fatal()) then + nc2l = 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 - l2_norm = psb_genrm2(w, p%precv(level)%base_desc, info) - iter = 0 + delta0 = psb_genrm2(w, base_desc, info) - if (l2_norm <= rtol*delta0) then - !Update solution x - call psb_geaxpby(alpha, d(idx), zone, x, p%precv(level)%base_desc, info) - else - iter = iter + 1 - idx=mod(iter,2) + !Apply the preconditioner + call vy2l%zero() - !Apply preconditioner - call psb_geaxpby(zone,w,zzero,p%wrk(level)%vx2l,p%precv(level)%base_desc,info) + idx=0 call inner_ml_aply(level,p,trans,work,info) - call psb_geaxpby(zone,p%wrk(level)%vy2l,zzero,d(idx),p%precv(level)%base_desc,info) - !Sparse matrix vector product + call psb_geaxpby(zone,vy2l,zzero,d(idx),base_desc,info) - call psb_spmm(zone,p%precv(level)%base_a,d(idx),zzero,v1,p%precv(level)%base_desc,info) + call psb_spmm(zone,base_a,d(idx),zzero,v,base_desc,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') goto 9999 end if - !tau1, tau2, tau3, tau4 + !FCG if (psb_toupper(trim(innersolv)) == 'FCG') then - tau1= psb_gedot(d(idx), v, p%precv(level)%base_desc, info) - tau2= psb_gedot(d(idx), v1, p%precv(level)%base_desc, info) - tau3= psb_gedot(d(idx), w, p%precv(level)%base_desc, info) - tau4= tau2 - (tau1*tau1)/tau + delta_old = psb_gedot(d(idx), w, base_desc, info) + tau = psb_gedot(d(idx), v, base_desc, info) + !GCR else if (psb_toupper(trim(innersolv)) == 'GCR') then - tau1= psb_gedot(v1, v, p%precv(level)%base_desc, info) - tau2= psb_gedot(v1, v1, p%precv(level)%base_desc, info) - tau3= psb_gedot(v1, w, p%precv(level)%base_desc, info) - tau4= tau2 - (tau1*tau1)/tau + delta_old = psb_gedot(v, w, base_desc, info) + tau = psb_gedot(v, v, base_desc, info) else call psb_errpush(psb_err_internal_error_,name,& & a_err='Invalid inner solver') goto 9999 endif - !Update solution - alpha=alpha-(tau1*tau3)/(tau*tau4) - call psb_geaxpby(alpha,d(idx - 1),zone,x,p%precv(level)%base_desc,info) - alpha=tau3/tau4 - call psb_geaxpby(alpha,d(idx),zone,x,p%precv(level)%base_desc,info) - endif + alpha = delta_old/tau + !Update residual w + call psb_geaxpby(-alpha, v, zone, w, base_desc, info) + + l2_norm = psb_genrm2(w, base_desc, info) + iter = 0 + + if (l2_norm <= rtol*delta0) then + !Update solution x + call psb_geaxpby(alpha, d(idx), zone, x, base_desc, info) + else + iter = iter + 1 + idx=mod(iter,2) - call psb_geaxpby(zone,x,zzero,p%wrk(level)%vy2l,p%precv(level)%base_desc,info) - !Free vectors - call psb_gefree(v, p%precv(level)%base_desc, info) - call psb_gefree(v1, p%precv(level)%base_desc, info) - call psb_gefree(w, p%precv(level)%base_desc, info) - call psb_gefree(x, p%precv(level)%base_desc, info) - call psb_gefree(d(0), p%precv(level)%base_desc, info) - call psb_gefree(d(1), p%precv(level)%base_desc, info) + !Apply preconditioner + call psb_geaxpby(zone,w,zzero,vx2l,base_desc,info) + call inner_ml_aply(level,p,trans,work,info) + call psb_geaxpby(zone,vy2l,zzero,d(idx),base_desc,info) + + !Sparse matrix vector product + + call psb_spmm(zone,base_a,d(idx),zzero,v1,base_desc,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + + !tau1, tau2, tau3, tau4 + if (psb_toupper(trim(innersolv)) == 'FCG') then + tau1= psb_gedot(d(idx), v, base_desc, info) + tau2= psb_gedot(d(idx), v1, base_desc, info) + tau3= psb_gedot(d(idx), w, base_desc, info) + tau4= tau2 - (tau1*tau1)/tau + else if (psb_toupper(trim(innersolv)) == 'GCR') then + tau1= psb_gedot(v1, v, base_desc, info) + tau2= psb_gedot(v1, v1, base_desc, info) + tau3= psb_gedot(v1, w, base_desc, info) + tau4= tau2 - (tau1*tau1)/tau + else + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid inner solver') + goto 9999 + endif + + !Update solution + alpha=alpha-(tau1*tau3)/(tau*tau4) + call psb_geaxpby(alpha,d(idx - 1),zone,x,base_desc,info) + alpha=tau3/tau4 + call psb_geaxpby(alpha,d(idx),zone,x,base_desc,info) + endif + call psb_geaxpby(zone,x,zzero,vy2l,base_desc,info) + !Free vectors + call psb_gefree(v, base_desc, info) + call psb_gefree(v1, base_desc, info) + call psb_gefree(w, base_desc, info) + call psb_gefree(x, base_desc, info) + call psb_gefree(d(0), base_desc, info) + call psb_gefree(d(1), base_desc, info) + end associate 9999 continue call psb_erractionrestore(err_act) if (err_act.eq.psb_act_abort_) then diff --git a/mlprec/mld_c_onelev_mod.f90 b/mlprec/mld_c_onelev_mod.f90 index d42b2b0e..b76119a3 100644 --- a/mlprec/mld_c_onelev_mod.f90 +++ b/mlprec/mld_c_onelev_mod.f90 @@ -552,11 +552,12 @@ contains ! ! Now for the ML application itself ! - ! We have VTX/VTY/VX2L/VY2L + + ! VTX/VTY/VX2L/VY2L are stored explicitly ! - val = val + 4 + ! - ! plus some additions for specific ML/cycles + ! additions for specific ML/cycles ! select case(lv%parms%ml_cycle) case(mld_add_ml_,mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_) @@ -586,6 +587,19 @@ contains info = psb_success_ nwv = lv%get_wrksz() write(0,*) 'Debug allocate_wrk: ',nwv + call psb_geasb(lv%wrk%vx2l,& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(lv%wrk%vy2l,& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(lv%wrk%vtx,& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(lv%wrk%vty,& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + end subroutine c_base_onelev_allocate_wrk @@ -597,6 +611,10 @@ contains ! integer(psb_ipk_) :: nwv info = psb_success_ + call lv%wrk%vx2l%free(info) + call lv%wrk%vy2l%free(info) + call lv%wrk%vtx%free(info) + call lv%wrk%vty%free(info) end subroutine c_base_onelev_free_wrk end module mld_c_onelev_mod diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index bb6ae569..ce9d0157 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -552,11 +552,12 @@ contains ! ! Now for the ML application itself ! - ! We have VTX/VTY/VX2L/VY2L + + ! VTX/VTY/VX2L/VY2L are stored explicitly ! - val = val + 4 + ! - ! plus some additions for specific ML/cycles + ! additions for specific ML/cycles ! select case(lv%parms%ml_cycle) case(mld_add_ml_,mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_) @@ -586,6 +587,19 @@ contains info = psb_success_ nwv = lv%get_wrksz() write(0,*) 'Debug allocate_wrk: ',nwv + call psb_geasb(lv%wrk%vx2l,& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(lv%wrk%vy2l,& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(lv%wrk%vtx,& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(lv%wrk%vty,& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + end subroutine d_base_onelev_allocate_wrk @@ -597,6 +611,10 @@ contains ! integer(psb_ipk_) :: nwv info = psb_success_ + call lv%wrk%vx2l%free(info) + call lv%wrk%vy2l%free(info) + call lv%wrk%vtx%free(info) + call lv%wrk%vty%free(info) end subroutine d_base_onelev_free_wrk end module mld_d_onelev_mod diff --git a/mlprec/mld_s_onelev_mod.f90 b/mlprec/mld_s_onelev_mod.f90 index c81488ac..88f6bf14 100644 --- a/mlprec/mld_s_onelev_mod.f90 +++ b/mlprec/mld_s_onelev_mod.f90 @@ -552,11 +552,12 @@ contains ! ! Now for the ML application itself ! - ! We have VTX/VTY/VX2L/VY2L + + ! VTX/VTY/VX2L/VY2L are stored explicitly ! - val = val + 4 + ! - ! plus some additions for specific ML/cycles + ! additions for specific ML/cycles ! select case(lv%parms%ml_cycle) case(mld_add_ml_,mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_) @@ -586,6 +587,19 @@ contains info = psb_success_ nwv = lv%get_wrksz() write(0,*) 'Debug allocate_wrk: ',nwv + call psb_geasb(lv%wrk%vx2l,& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(lv%wrk%vy2l,& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(lv%wrk%vtx,& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(lv%wrk%vty,& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + end subroutine s_base_onelev_allocate_wrk @@ -597,6 +611,10 @@ contains ! integer(psb_ipk_) :: nwv info = psb_success_ + call lv%wrk%vx2l%free(info) + call lv%wrk%vy2l%free(info) + call lv%wrk%vtx%free(info) + call lv%wrk%vty%free(info) end subroutine s_base_onelev_free_wrk end module mld_s_onelev_mod diff --git a/mlprec/mld_z_onelev_mod.f90 b/mlprec/mld_z_onelev_mod.f90 index 619c4053..94a8fe43 100644 --- a/mlprec/mld_z_onelev_mod.f90 +++ b/mlprec/mld_z_onelev_mod.f90 @@ -552,11 +552,12 @@ contains ! ! Now for the ML application itself ! - ! We have VTX/VTY/VX2L/VY2L + + ! VTX/VTY/VX2L/VY2L are stored explicitly ! - val = val + 4 + ! - ! plus some additions for specific ML/cycles + ! additions for specific ML/cycles ! select case(lv%parms%ml_cycle) case(mld_add_ml_,mld_mult_ml_,mld_vcycle_ml_, mld_wcycle_ml_) @@ -586,6 +587,19 @@ contains info = psb_success_ nwv = lv%get_wrksz() write(0,*) 'Debug allocate_wrk: ',nwv + call psb_geasb(lv%wrk%vx2l,& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(lv%wrk%vy2l,& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(lv%wrk%vtx,& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(lv%wrk%vty,& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + end subroutine z_base_onelev_allocate_wrk @@ -597,6 +611,10 @@ contains ! integer(psb_ipk_) :: nwv info = psb_success_ + call lv%wrk%vx2l%free(info) + call lv%wrk%vy2l%free(info) + call lv%wrk%vtx%free(info) + call lv%wrk%vty%free(info) end subroutine z_base_onelev_free_wrk end module mld_z_onelev_mod From 823db4f943aa7be9ef193195b76bfe070f6bb551 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 11 Dec 2017 10:21:00 +0000 Subject: [PATCH 08/16] Fixed allocte_wrk & free_wrk for WV allocation. Modified interface of smoothers to use WV. Initial tests. Added WV to calls to MAP_X2Y & MAP_Y2X. --- mlprec/impl/mld_cmlprec_aply.f90 | 68 ++++--- mlprec/impl/mld_cprecaply.f90 | 155 ++++++++-------- mlprec/impl/mld_cprecset.F90 | 4 +- mlprec/impl/mld_dmlprec_aply.f90 | 68 ++++--- mlprec/impl/mld_dprecaply.f90 | 155 ++++++++-------- mlprec/impl/mld_dprecset.F90 | 4 +- mlprec/impl/mld_smlprec_aply.f90 | 68 ++++--- mlprec/impl/mld_sprecaply.f90 | 155 ++++++++-------- mlprec/impl/mld_sprecset.F90 | 4 +- mlprec/impl/mld_zmlprec_aply.f90 | 68 ++++--- mlprec/impl/mld_zprecaply.f90 | 155 ++++++++-------- mlprec/impl/mld_zprecset.F90 | 4 +- .../smoother/mld_c_as_smoother_apply_vect.f90 | 167 +++++++++--------- .../mld_c_base_smoother_apply_vect.f90 | 4 +- .../mld_c_jac_smoother_apply_vect.f90 | 133 +++++++------- .../smoother/mld_d_as_smoother_apply_vect.f90 | 167 +++++++++--------- .../mld_d_base_smoother_apply_vect.f90 | 4 +- .../mld_d_jac_smoother_apply_vect.f90 | 133 +++++++------- .../smoother/mld_s_as_smoother_apply_vect.f90 | 167 +++++++++--------- .../mld_s_base_smoother_apply_vect.f90 | 4 +- .../mld_s_jac_smoother_apply_vect.f90 | 133 +++++++------- .../smoother/mld_z_as_smoother_apply_vect.f90 | 167 +++++++++--------- .../mld_z_base_smoother_apply_vect.f90 | 4 +- .../mld_z_jac_smoother_apply_vect.f90 | 133 +++++++------- mlprec/mld_c_as_smoother.f90 | 4 +- mlprec/mld_c_base_smoother_mod.f90 | 4 +- mlprec/mld_c_jac_smoother.f90 | 4 +- mlprec/mld_c_onelev_mod.f90 | 17 +- mlprec/mld_d_as_smoother.f90 | 4 +- mlprec/mld_d_base_smoother_mod.f90 | 4 +- mlprec/mld_d_jac_smoother.f90 | 4 +- mlprec/mld_d_onelev_mod.f90 | 17 +- mlprec/mld_s_as_smoother.f90 | 4 +- mlprec/mld_s_base_smoother_mod.f90 | 4 +- mlprec/mld_s_jac_smoother.f90 | 4 +- mlprec/mld_s_onelev_mod.f90 | 17 +- mlprec/mld_z_as_smoother.f90 | 4 +- mlprec/mld_z_base_smoother_mod.f90 | 4 +- mlprec/mld_z_jac_smoother.f90 | 4 +- mlprec/mld_z_onelev_mod.f90 | 17 +- 40 files changed, 1212 insertions(+), 1028 deletions(-) diff --git a/mlprec/impl/mld_cmlprec_aply.f90 b/mlprec/impl/mld_cmlprec_aply.f90 index 11629f69..3ba3d8c4 100644 --- a/mlprec/impl/mld_cmlprec_aply.f90 +++ b/mlprec/impl/mld_cmlprec_aply.f90 @@ -255,7 +255,8 @@ subroutine mld_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv(:)) ! ! At first iteration we must use the input BETA ! @@ -482,7 +483,8 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv) if (allocated(p%precv(level)%sm2a)) then call psb_geaxpby(cone,& @@ -494,12 +496,12 @@ contains call p%precv(level)%sm%apply(cone,& & vy2l,czero,vty,& & base_desc, trans,& - & ione,work,info,init='Z') + & ione,work,wv,info,init='Z') call p%precv(level)%sm2a%apply(cone,& & vty,czero,vy2l,& & base_desc, trans,& - & ione,work,info,init='Z') + & ione,work,wv,info,init='Z') end do else @@ -507,7 +509,7 @@ contains call p%precv(level)%sm%apply(cone,& & vx2l,czero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -519,7 +521,8 @@ contains ! Apply the restriction call psb_map_X2Y(cone,vx2l,& & czero,p%precv(level+1)%wrk%vx2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') @@ -538,7 +541,8 @@ contains ! call psb_map_Y2X(cone,p%precv(level+1)%wrk%vy2l,& & cone,vy2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during prolongation') @@ -605,7 +609,8 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv) if (level < nlev) then ! ! Apply the first smoother @@ -618,13 +623,13 @@ contains if (info == psb_success_) call p%precv(level)%sm%apply(cone,& & vx2l,czero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& & vx2l,czero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then @@ -651,7 +656,8 @@ contains end if call psb_map_X2Y(cone,vty,& & czero,p%precv(level+1)%wrk%vx2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') @@ -661,7 +667,8 @@ contains ! Shortcut: just transfer x2l. call psb_map_X2Y(cone,vx2l,& & czero,p%precv(level+1)%wrk%vx2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') @@ -676,7 +683,8 @@ contains ! call psb_map_Y2X(cone,p%precv(level+1)%wrk%vy2l,& & cone,vy2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during prolongation') @@ -693,7 +701,8 @@ contains & base_desc,info,work=work,trans=trans) if (info == psb_success_) call psb_map_X2Y(cone,vty,& & czero,p%precv(level+1)%wrk%vx2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during W-cycle restriction') @@ -704,7 +713,8 @@ contains if (info == psb_success_) call psb_map_Y2X(cone,p%precv(level+1)%wrk%vy2l,& & cone,vy2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -737,13 +747,13 @@ contains if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& & vty,cone,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& & vty,cone,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then @@ -760,7 +770,7 @@ contains if (info == psb_success_) call p%precv(level)%sm%apply(cone,& & vx2l,czero,vy2l,& & base_desc, trans,& - & sweeps,work,info) + & sweeps,work,wv,info) else @@ -836,7 +846,8 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv) if (level == nlev) then ! ! Apply smoother @@ -845,7 +856,7 @@ contains if (info == psb_success_) call p%precv(level)%sm%apply(cone,& & vx2l,czero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else if (level < nlev) then @@ -854,13 +865,13 @@ contains if (info == psb_success_) call p%precv(level)%sm%apply(cone,& & vx2l,czero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& & vx2l,czero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then @@ -890,7 +901,8 @@ contains ! Apply the restriction call psb_map_X2Y(cone,vty,& & czero,p%precv(level + 1)%wrk%vx2l,& - & p%precv(level + 1)%map,info,work=work) + & p%precv(level + 1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -925,7 +937,8 @@ contains ! call psb_map_Y2X(cone,p%precv(level+1)%wrk%vy2l,& & cone,vy2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -955,13 +968,13 @@ contains if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& & vty,cone,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& & vty,cone,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then @@ -1014,7 +1027,8 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv) !Assemble rhs, w, v, v1, x diff --git a/mlprec/impl/mld_cprecaply.f90 b/mlprec/impl/mld_cprecaply.f90 index 4e8a99c4..3641d26e 100644 --- a/mlprec/impl/mld_cprecaply.f90 +++ b/mlprec/impl/mld_cprecaply.f90 @@ -323,6 +323,7 @@ subroutine mld_cprecaply2_vect(prec,x,y,desc_data,info,trans,work) complex(psb_spk_), pointer :: work_(:) integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: err_act,iwsz, k, nswps + logical :: do_alloc_wrk character(len=20) :: name name='mld_cprecaply' @@ -358,6 +359,10 @@ subroutine mld_cprecaply2_vect(prec,x,y,desc_data,info,trans,work) call psb_errpush(info,name) goto 9999 end if + + do_alloc_wrk = .not.allocated(prec%wrk) + if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) + if (size(prec%precv) >1) then ! ! Number of levels > 1: apply the multilevel preconditioner @@ -375,31 +380,29 @@ subroutine mld_cprecaply2_vect(prec,x,y,desc_data,info,trans,work) ! nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post) - if (allocated(prec%precv(1)%sm2a)) then - ! - ! This is a kludge for handling the symmetrized GS case. - ! Will need some rethinking. - ! - twoside: block - type(psb_c_vect_type) :: w1,w2 - call psb_geasb(w1,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(w2,desc_data,info,mold=x%v,scratch=.true.) + associate(w1 => prec%precv(1)%wrk%vx2l, w2 => prec%precv(1)%wrk%vy2l,& + & wv => prec%precv(1)%wrk%wv) + if (allocated(prec%precv(1)%sm2a)) then + ! + ! This is a kludge for handling the symmetrized GS case. + ! Will need some rethinking. + ! call psb_geaxpby(cone,x,czero,w1,desc_data,info) select case(trans_) case ('N') do k=1, nswps call prec%precv(1)%sm%apply(cone,w1,czero,w2,desc_data,trans_,& - & ione, work_,info) + & ione, work_,wv,info) call prec%precv(1)%sm2a%apply(cone,w2,czero,w1,desc_data,trans_,& - & ione, work_,info) + & ione, work_,wv,info) end do - + case('T','C') do k=1, nswps call prec%precv(1)%sm2a%apply(cone,w1,czero,w2,desc_data,trans_,& - & ione, work_,info) + & ione, work_,wv,info) call prec%precv(1)%sm%apply(cone,w2,czero,w1,desc_data,trans_,& - & ione, work_,info) + & ione, work_,wv,info) end do case default info = psb_err_from_subroutine_ @@ -407,14 +410,12 @@ subroutine mld_cprecaply2_vect(prec,x,y,desc_data,info,trans,work) goto 9999 end select call psb_geaxpby(cone,w1,czero,y,desc_data,info) - call psb_gefree(w1,desc_data,info) - call psb_gefree(w2,desc_data,info) - end block twoside - - else - call prec%precv(1)%sm%apply(cone,x,czero,y,desc_data,trans_,& - & nswps,work_,info) - end if + else + call prec%precv(1)%sm%apply(cone,x,czero,y,desc_data,trans_,& + & nswps,work_,wv,info) + end if + end associate + else info = psb_err_from_subroutine_ai_ @@ -426,6 +427,7 @@ subroutine mld_cprecaply2_vect(prec,x,y,desc_data,info,trans,work) ! If the original distribution has an overlap we should fix that. call psb_halo(y,desc_data,info,data=psb_comm_mov_) + if (do_alloc_wrk) call prec%free_wrk(info) if (present(work)) then else @@ -459,10 +461,10 @@ subroutine mld_cprecaply1_vect(prec,x,desc_data,info,trans,work) ! Local variables character :: trans_ - type(psb_c_vect_type) :: ww complex(psb_spk_), pointer :: work_(:) integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: err_act,iwsz, k, nswps + logical :: do_alloc_wrk character(len=20) :: name name='mld_cprecaply' @@ -498,63 +500,68 @@ subroutine mld_cprecaply1_vect(prec,x,desc_data,info,trans,work) call psb_errpush(info,name) goto 9999 end if - 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 - ! - call mld_mlprec_aply(cone,prec,x,czero,ww,desc_data,trans_,work_,info) - if (info == 0) call psb_geaxpby(cone,ww,czero,x,desc_data,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_cmlprec_aply') - goto 9999 - end if + + do_alloc_wrk = .not.allocated(prec%wrk) + if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) - else if (size(prec%precv) == 1) then - ! - ! Number of levels = 1: apply the base preconditioner - ! - nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post) - if (allocated(prec%precv(1)%sm2a)) then + 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 ! - ! This is a kludge for handling the symmetrized GS case. - ! Will need some rethinking. + ! Number of levels > 1: apply the multilevel preconditioner ! - select case(trans_) - case ('N') - do k=1, nswps - call prec%precv(1)%sm%apply(cone,x,czero,ww,desc_data,trans_,& - & ione, work_,info) - call prec%precv(1)%sm2a%apply(cone,ww,czero,x,desc_data,trans_,& - & ione, work_,info) - end do - case('T','C') - do k=1, nswps - call prec%precv(1)%sm2a%apply(cone,x,czero,ww,desc_data,trans_,& - & ione, work_,info) - call prec%precv(1)%sm%apply(cone,ww,czero,x,desc_data,trans_,& - & ione, work_,info) - end do - case default - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Invalid trans') - goto 9999 - end select - - else - call prec%precv(1)%sm%apply(cone,x,czero,ww,desc_data,trans_,& - & nswps, work_,info) + call mld_mlprec_aply(cone,prec,x,czero,ww,desc_data,trans_,work_,info) if (info == 0) call psb_geaxpby(cone,ww,czero,x,desc_data,info) - end if - else + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_cmlprec_aply') + goto 9999 + end if - info = psb_err_from_subroutine_ai_ - call psb_errpush(info,name,a_err='Invalid size of precv',& - & i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/)) - goto 9999 - endif + else if (size(prec%precv) == 1) then + ! + ! Number of levels = 1: apply the base preconditioner + ! + nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post) + if (allocated(prec%precv(1)%sm2a)) then + ! + ! This is a kludge for handling the symmetrized GS case. + ! Will need some rethinking. + ! + select case(trans_) + case ('N') + do k=1, nswps + call prec%precv(1)%sm%apply(cone,x,czero,ww,desc_data,trans_,& + & ione, work_,wv,info) + call prec%precv(1)%sm2a%apply(cone,ww,czero,x,desc_data,trans_,& + & ione, work_,wv,info) + end do + case('T','C') + do k=1, nswps + call prec%precv(1)%sm2a%apply(cone,x,czero,ww,desc_data,trans_,& + & ione, work_,wv,info) + call prec%precv(1)%sm%apply(cone,ww,czero,x,desc_data,trans_,& + & ione, work_,wv,info) + end do + case default + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Invalid trans') + goto 9999 + end select - if (info == 0) call psb_gefree(ww,desc_data,info) + else + call prec%precv(1)%sm%apply(cone,x,czero,ww,desc_data,trans_,& + & nswps, work_,wv,info) + if (info == 0) call psb_geaxpby(cone,ww,czero,x,desc_data,info) + end if + else + + info = psb_err_from_subroutine_ai_ + call psb_errpush(info,name,a_err='Invalid size of precv',& + & i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/)) + 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_) diff --git a/mlprec/impl/mld_cprecset.F90 b/mlprec/impl/mld_cprecset.F90 index 0ef1fb91..307c4e81 100644 --- a/mlprec/impl/mld_cprecset.F90 +++ b/mlprec/impl/mld_cprecset.F90 @@ -432,7 +432,7 @@ subroutine mld_cprecsetsm(p,val,info,ilev,ilmax,pos) ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin_, ilmax_ - character(len=*), parameter :: name='mld_precseti' + character(len=*), parameter :: name='mld_precsetsm' info = psb_success_ @@ -495,7 +495,7 @@ subroutine mld_cprecsetsv(p,val,info,ilev,ilmax,pos) ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin_, ilmax_ - character(len=*), parameter :: name='mld_precseti' + character(len=*), parameter :: name='mld_precsetsv' info = psb_success_ diff --git a/mlprec/impl/mld_dmlprec_aply.f90 b/mlprec/impl/mld_dmlprec_aply.f90 index 4a046d80..e7d74c11 100644 --- a/mlprec/impl/mld_dmlprec_aply.f90 +++ b/mlprec/impl/mld_dmlprec_aply.f90 @@ -255,7 +255,8 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv(:)) ! ! At first iteration we must use the input BETA ! @@ -482,7 +483,8 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv) if (allocated(p%precv(level)%sm2a)) then call psb_geaxpby(done,& @@ -494,12 +496,12 @@ contains call p%precv(level)%sm%apply(done,& & vy2l,dzero,vty,& & base_desc, trans,& - & ione,work,info,init='Z') + & ione,work,wv,info,init='Z') call p%precv(level)%sm2a%apply(done,& & vty,dzero,vy2l,& & base_desc, trans,& - & ione,work,info,init='Z') + & ione,work,wv,info,init='Z') end do else @@ -507,7 +509,7 @@ contains call p%precv(level)%sm%apply(done,& & vx2l,dzero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -519,7 +521,8 @@ contains ! Apply the restriction call psb_map_X2Y(done,vx2l,& & dzero,p%precv(level+1)%wrk%vx2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') @@ -538,7 +541,8 @@ contains ! call psb_map_Y2X(done,p%precv(level+1)%wrk%vy2l,& & done,vy2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during prolongation') @@ -605,7 +609,8 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv) if (level < nlev) then ! ! Apply the first smoother @@ -618,13 +623,13 @@ contains if (info == psb_success_) call p%precv(level)%sm%apply(done,& & vx2l,dzero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(done,& & vx2l,dzero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then @@ -651,7 +656,8 @@ contains end if call psb_map_X2Y(done,vty,& & dzero,p%precv(level+1)%wrk%vx2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') @@ -661,7 +667,8 @@ contains ! Shortcut: just transfer x2l. call psb_map_X2Y(done,vx2l,& & dzero,p%precv(level+1)%wrk%vx2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') @@ -676,7 +683,8 @@ contains ! call psb_map_Y2X(done,p%precv(level+1)%wrk%vy2l,& & done,vy2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during prolongation') @@ -693,7 +701,8 @@ contains & base_desc,info,work=work,trans=trans) if (info == psb_success_) call psb_map_X2Y(done,vty,& & dzero,p%precv(level+1)%wrk%vx2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during W-cycle restriction') @@ -704,7 +713,8 @@ contains if (info == psb_success_) call psb_map_Y2X(done,p%precv(level+1)%wrk%vy2l,& & done,vy2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -737,13 +747,13 @@ contains if (info == psb_success_) call p%precv(level)%sm2%apply(done,& & vty,done,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& & vty,done,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then @@ -760,7 +770,7 @@ contains if (info == psb_success_) call p%precv(level)%sm%apply(done,& & vx2l,dzero,vy2l,& & base_desc, trans,& - & sweeps,work,info) + & sweeps,work,wv,info) else @@ -836,7 +846,8 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv) if (level == nlev) then ! ! Apply smoother @@ -845,7 +856,7 @@ contains if (info == psb_success_) call p%precv(level)%sm%apply(done,& & vx2l,dzero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else if (level < nlev) then @@ -854,13 +865,13 @@ contains if (info == psb_success_) call p%precv(level)%sm%apply(done,& & vx2l,dzero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(done,& & vx2l,dzero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then @@ -890,7 +901,8 @@ contains ! Apply the restriction call psb_map_X2Y(done,vty,& & dzero,p%precv(level + 1)%wrk%vx2l,& - & p%precv(level + 1)%map,info,work=work) + & p%precv(level + 1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -925,7 +937,8 @@ contains ! call psb_map_Y2X(done,p%precv(level+1)%wrk%vy2l,& & done,vy2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -955,13 +968,13 @@ contains if (info == psb_success_) call p%precv(level)%sm2%apply(done,& & vty,done,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& & vty,done,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then @@ -1014,7 +1027,8 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv) !Assemble rhs, w, v, v1, x diff --git a/mlprec/impl/mld_dprecaply.f90 b/mlprec/impl/mld_dprecaply.f90 index bc91bb66..d9277daf 100644 --- a/mlprec/impl/mld_dprecaply.f90 +++ b/mlprec/impl/mld_dprecaply.f90 @@ -323,6 +323,7 @@ subroutine mld_dprecaply2_vect(prec,x,y,desc_data,info,trans,work) real(psb_dpk_), pointer :: work_(:) integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: err_act,iwsz, k, nswps + logical :: do_alloc_wrk character(len=20) :: name name='mld_dprecaply' @@ -358,6 +359,10 @@ subroutine mld_dprecaply2_vect(prec,x,y,desc_data,info,trans,work) call psb_errpush(info,name) goto 9999 end if + + do_alloc_wrk = .not.allocated(prec%wrk) + if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) + if (size(prec%precv) >1) then ! ! Number of levels > 1: apply the multilevel preconditioner @@ -375,31 +380,29 @@ subroutine mld_dprecaply2_vect(prec,x,y,desc_data,info,trans,work) ! nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post) - if (allocated(prec%precv(1)%sm2a)) then - ! - ! This is a kludge for handling the symmetrized GS case. - ! Will need some rethinking. - ! - twoside: block - type(psb_d_vect_type) :: w1,w2 - call psb_geasb(w1,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(w2,desc_data,info,mold=x%v,scratch=.true.) + associate(w1 => prec%precv(1)%wrk%vx2l, w2 => prec%precv(1)%wrk%vy2l,& + & wv => prec%precv(1)%wrk%wv) + if (allocated(prec%precv(1)%sm2a)) then + ! + ! This is a kludge for handling the symmetrized GS case. + ! Will need some rethinking. + ! call psb_geaxpby(done,x,dzero,w1,desc_data,info) select case(trans_) case ('N') do k=1, nswps call prec%precv(1)%sm%apply(done,w1,dzero,w2,desc_data,trans_,& - & ione, work_,info) + & ione, work_,wv,info) call prec%precv(1)%sm2a%apply(done,w2,dzero,w1,desc_data,trans_,& - & ione, work_,info) + & ione, work_,wv,info) end do - + case('T','C') do k=1, nswps call prec%precv(1)%sm2a%apply(done,w1,dzero,w2,desc_data,trans_,& - & ione, work_,info) + & ione, work_,wv,info) call prec%precv(1)%sm%apply(done,w2,dzero,w1,desc_data,trans_,& - & ione, work_,info) + & ione, work_,wv,info) end do case default info = psb_err_from_subroutine_ @@ -407,14 +410,12 @@ subroutine mld_dprecaply2_vect(prec,x,y,desc_data,info,trans,work) goto 9999 end select call psb_geaxpby(done,w1,dzero,y,desc_data,info) - call psb_gefree(w1,desc_data,info) - call psb_gefree(w2,desc_data,info) - end block twoside - - else - call prec%precv(1)%sm%apply(done,x,dzero,y,desc_data,trans_,& - & nswps,work_,info) - end if + else + call prec%precv(1)%sm%apply(done,x,dzero,y,desc_data,trans_,& + & nswps,work_,wv,info) + end if + end associate + else info = psb_err_from_subroutine_ai_ @@ -426,6 +427,7 @@ subroutine mld_dprecaply2_vect(prec,x,y,desc_data,info,trans,work) ! If the original distribution has an overlap we should fix that. call psb_halo(y,desc_data,info,data=psb_comm_mov_) + if (do_alloc_wrk) call prec%free_wrk(info) if (present(work)) then else @@ -459,10 +461,10 @@ subroutine mld_dprecaply1_vect(prec,x,desc_data,info,trans,work) ! Local variables character :: trans_ - type(psb_d_vect_type) :: ww real(psb_dpk_), pointer :: work_(:) integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: err_act,iwsz, k, nswps + logical :: do_alloc_wrk character(len=20) :: name name='mld_dprecaply' @@ -498,63 +500,68 @@ subroutine mld_dprecaply1_vect(prec,x,desc_data,info,trans,work) call psb_errpush(info,name) goto 9999 end if - 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 - ! - call mld_mlprec_aply(done,prec,x,dzero,ww,desc_data,trans_,work_,info) - if (info == 0) call psb_geaxpby(done,ww,dzero,x,desc_data,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_dmlprec_aply') - goto 9999 - end if + + do_alloc_wrk = .not.allocated(prec%wrk) + if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) - else if (size(prec%precv) == 1) then - ! - ! Number of levels = 1: apply the base preconditioner - ! - nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post) - if (allocated(prec%precv(1)%sm2a)) then + 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 ! - ! This is a kludge for handling the symmetrized GS case. - ! Will need some rethinking. + ! Number of levels > 1: apply the multilevel preconditioner ! - select case(trans_) - case ('N') - do k=1, nswps - call prec%precv(1)%sm%apply(done,x,dzero,ww,desc_data,trans_,& - & ione, work_,info) - call prec%precv(1)%sm2a%apply(done,ww,dzero,x,desc_data,trans_,& - & ione, work_,info) - end do - case('T','C') - do k=1, nswps - call prec%precv(1)%sm2a%apply(done,x,dzero,ww,desc_data,trans_,& - & ione, work_,info) - call prec%precv(1)%sm%apply(done,ww,dzero,x,desc_data,trans_,& - & ione, work_,info) - end do - case default - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Invalid trans') - goto 9999 - end select - - else - call prec%precv(1)%sm%apply(done,x,dzero,ww,desc_data,trans_,& - & nswps, work_,info) + call mld_mlprec_aply(done,prec,x,dzero,ww,desc_data,trans_,work_,info) if (info == 0) call psb_geaxpby(done,ww,dzero,x,desc_data,info) - end if - else + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_dmlprec_aply') + goto 9999 + end if - info = psb_err_from_subroutine_ai_ - call psb_errpush(info,name,a_err='Invalid size of precv',& - & i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/)) - goto 9999 - endif + else if (size(prec%precv) == 1) then + ! + ! Number of levels = 1: apply the base preconditioner + ! + nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post) + if (allocated(prec%precv(1)%sm2a)) then + ! + ! This is a kludge for handling the symmetrized GS case. + ! Will need some rethinking. + ! + select case(trans_) + case ('N') + do k=1, nswps + call prec%precv(1)%sm%apply(done,x,dzero,ww,desc_data,trans_,& + & ione, work_,wv,info) + call prec%precv(1)%sm2a%apply(done,ww,dzero,x,desc_data,trans_,& + & ione, work_,wv,info) + end do + case('T','C') + do k=1, nswps + call prec%precv(1)%sm2a%apply(done,x,dzero,ww,desc_data,trans_,& + & ione, work_,wv,info) + call prec%precv(1)%sm%apply(done,ww,dzero,x,desc_data,trans_,& + & ione, work_,wv,info) + end do + case default + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Invalid trans') + goto 9999 + end select - if (info == 0) call psb_gefree(ww,desc_data,info) + else + call prec%precv(1)%sm%apply(done,x,dzero,ww,desc_data,trans_,& + & nswps, work_,wv,info) + if (info == 0) call psb_geaxpby(done,ww,dzero,x,desc_data,info) + end if + else + + info = psb_err_from_subroutine_ai_ + call psb_errpush(info,name,a_err='Invalid size of precv',& + & i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/)) + 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_) diff --git a/mlprec/impl/mld_dprecset.F90 b/mlprec/impl/mld_dprecset.F90 index 3c74b628..9bf541e0 100644 --- a/mlprec/impl/mld_dprecset.F90 +++ b/mlprec/impl/mld_dprecset.F90 @@ -465,7 +465,7 @@ subroutine mld_dprecsetsm(p,val,info,ilev,ilmax,pos) ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin_, ilmax_ - character(len=*), parameter :: name='mld_precseti' + character(len=*), parameter :: name='mld_precsetsm' info = psb_success_ @@ -528,7 +528,7 @@ subroutine mld_dprecsetsv(p,val,info,ilev,ilmax,pos) ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin_, ilmax_ - character(len=*), parameter :: name='mld_precseti' + character(len=*), parameter :: name='mld_precsetsv' info = psb_success_ diff --git a/mlprec/impl/mld_smlprec_aply.f90 b/mlprec/impl/mld_smlprec_aply.f90 index 7ab23307..5a62c214 100644 --- a/mlprec/impl/mld_smlprec_aply.f90 +++ b/mlprec/impl/mld_smlprec_aply.f90 @@ -255,7 +255,8 @@ subroutine mld_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv(:)) ! ! At first iteration we must use the input BETA ! @@ -482,7 +483,8 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv) if (allocated(p%precv(level)%sm2a)) then call psb_geaxpby(sone,& @@ -494,12 +496,12 @@ contains call p%precv(level)%sm%apply(sone,& & vy2l,szero,vty,& & base_desc, trans,& - & ione,work,info,init='Z') + & ione,work,wv,info,init='Z') call p%precv(level)%sm2a%apply(sone,& & vty,szero,vy2l,& & base_desc, trans,& - & ione,work,info,init='Z') + & ione,work,wv,info,init='Z') end do else @@ -507,7 +509,7 @@ contains call p%precv(level)%sm%apply(sone,& & vx2l,szero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -519,7 +521,8 @@ contains ! Apply the restriction call psb_map_X2Y(sone,vx2l,& & szero,p%precv(level+1)%wrk%vx2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') @@ -538,7 +541,8 @@ contains ! call psb_map_Y2X(sone,p%precv(level+1)%wrk%vy2l,& & sone,vy2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during prolongation') @@ -605,7 +609,8 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv) if (level < nlev) then ! ! Apply the first smoother @@ -618,13 +623,13 @@ contains if (info == psb_success_) call p%precv(level)%sm%apply(sone,& & vx2l,szero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& & vx2l,szero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then @@ -651,7 +656,8 @@ contains end if call psb_map_X2Y(sone,vty,& & szero,p%precv(level+1)%wrk%vx2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') @@ -661,7 +667,8 @@ contains ! Shortcut: just transfer x2l. call psb_map_X2Y(sone,vx2l,& & szero,p%precv(level+1)%wrk%vx2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') @@ -676,7 +683,8 @@ contains ! call psb_map_Y2X(sone,p%precv(level+1)%wrk%vy2l,& & sone,vy2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during prolongation') @@ -693,7 +701,8 @@ contains & base_desc,info,work=work,trans=trans) if (info == psb_success_) call psb_map_X2Y(sone,vty,& & szero,p%precv(level+1)%wrk%vx2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during W-cycle restriction') @@ -704,7 +713,8 @@ contains if (info == psb_success_) call psb_map_Y2X(sone,p%precv(level+1)%wrk%vy2l,& & sone,vy2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -737,13 +747,13 @@ contains if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& & vty,sone,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& & vty,sone,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then @@ -760,7 +770,7 @@ contains if (info == psb_success_) call p%precv(level)%sm%apply(sone,& & vx2l,szero,vy2l,& & base_desc, trans,& - & sweeps,work,info) + & sweeps,work,wv,info) else @@ -836,7 +846,8 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv) if (level == nlev) then ! ! Apply smoother @@ -845,7 +856,7 @@ contains if (info == psb_success_) call p%precv(level)%sm%apply(sone,& & vx2l,szero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else if (level < nlev) then @@ -854,13 +865,13 @@ contains if (info == psb_success_) call p%precv(level)%sm%apply(sone,& & vx2l,szero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& & vx2l,szero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then @@ -890,7 +901,8 @@ contains ! Apply the restriction call psb_map_X2Y(sone,vty,& & szero,p%precv(level + 1)%wrk%vx2l,& - & p%precv(level + 1)%map,info,work=work) + & p%precv(level + 1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -925,7 +937,8 @@ contains ! call psb_map_Y2X(sone,p%precv(level+1)%wrk%vy2l,& & sone,vy2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -955,13 +968,13 @@ contains if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& & vty,sone,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& & vty,sone,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then @@ -1014,7 +1027,8 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv) !Assemble rhs, w, v, v1, x diff --git a/mlprec/impl/mld_sprecaply.f90 b/mlprec/impl/mld_sprecaply.f90 index b68d3421..e4065b7b 100644 --- a/mlprec/impl/mld_sprecaply.f90 +++ b/mlprec/impl/mld_sprecaply.f90 @@ -323,6 +323,7 @@ subroutine mld_sprecaply2_vect(prec,x,y,desc_data,info,trans,work) real(psb_spk_), pointer :: work_(:) integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: err_act,iwsz, k, nswps + logical :: do_alloc_wrk character(len=20) :: name name='mld_sprecaply' @@ -358,6 +359,10 @@ subroutine mld_sprecaply2_vect(prec,x,y,desc_data,info,trans,work) call psb_errpush(info,name) goto 9999 end if + + do_alloc_wrk = .not.allocated(prec%wrk) + if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) + if (size(prec%precv) >1) then ! ! Number of levels > 1: apply the multilevel preconditioner @@ -375,31 +380,29 @@ subroutine mld_sprecaply2_vect(prec,x,y,desc_data,info,trans,work) ! nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post) - if (allocated(prec%precv(1)%sm2a)) then - ! - ! This is a kludge for handling the symmetrized GS case. - ! Will need some rethinking. - ! - twoside: block - type(psb_s_vect_type) :: w1,w2 - call psb_geasb(w1,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(w2,desc_data,info,mold=x%v,scratch=.true.) + associate(w1 => prec%precv(1)%wrk%vx2l, w2 => prec%precv(1)%wrk%vy2l,& + & wv => prec%precv(1)%wrk%wv) + if (allocated(prec%precv(1)%sm2a)) then + ! + ! This is a kludge for handling the symmetrized GS case. + ! Will need some rethinking. + ! call psb_geaxpby(sone,x,szero,w1,desc_data,info) select case(trans_) case ('N') do k=1, nswps call prec%precv(1)%sm%apply(sone,w1,szero,w2,desc_data,trans_,& - & ione, work_,info) + & ione, work_,wv,info) call prec%precv(1)%sm2a%apply(sone,w2,szero,w1,desc_data,trans_,& - & ione, work_,info) + & ione, work_,wv,info) end do - + case('T','C') do k=1, nswps call prec%precv(1)%sm2a%apply(sone,w1,szero,w2,desc_data,trans_,& - & ione, work_,info) + & ione, work_,wv,info) call prec%precv(1)%sm%apply(sone,w2,szero,w1,desc_data,trans_,& - & ione, work_,info) + & ione, work_,wv,info) end do case default info = psb_err_from_subroutine_ @@ -407,14 +410,12 @@ subroutine mld_sprecaply2_vect(prec,x,y,desc_data,info,trans,work) goto 9999 end select call psb_geaxpby(sone,w1,szero,y,desc_data,info) - call psb_gefree(w1,desc_data,info) - call psb_gefree(w2,desc_data,info) - end block twoside - - else - call prec%precv(1)%sm%apply(sone,x,szero,y,desc_data,trans_,& - & nswps,work_,info) - end if + else + call prec%precv(1)%sm%apply(sone,x,szero,y,desc_data,trans_,& + & nswps,work_,wv,info) + end if + end associate + else info = psb_err_from_subroutine_ai_ @@ -426,6 +427,7 @@ subroutine mld_sprecaply2_vect(prec,x,y,desc_data,info,trans,work) ! If the original distribution has an overlap we should fix that. call psb_halo(y,desc_data,info,data=psb_comm_mov_) + if (do_alloc_wrk) call prec%free_wrk(info) if (present(work)) then else @@ -459,10 +461,10 @@ subroutine mld_sprecaply1_vect(prec,x,desc_data,info,trans,work) ! Local variables character :: trans_ - type(psb_s_vect_type) :: ww real(psb_spk_), pointer :: work_(:) integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: err_act,iwsz, k, nswps + logical :: do_alloc_wrk character(len=20) :: name name='mld_sprecaply' @@ -498,63 +500,68 @@ subroutine mld_sprecaply1_vect(prec,x,desc_data,info,trans,work) call psb_errpush(info,name) goto 9999 end if - 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 - ! - call mld_mlprec_aply(sone,prec,x,szero,ww,desc_data,trans_,work_,info) - if (info == 0) call psb_geaxpby(sone,ww,szero,x,desc_data,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_smlprec_aply') - goto 9999 - end if + + do_alloc_wrk = .not.allocated(prec%wrk) + if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) - else if (size(prec%precv) == 1) then - ! - ! Number of levels = 1: apply the base preconditioner - ! - nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post) - if (allocated(prec%precv(1)%sm2a)) then + 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 ! - ! This is a kludge for handling the symmetrized GS case. - ! Will need some rethinking. + ! Number of levels > 1: apply the multilevel preconditioner ! - select case(trans_) - case ('N') - do k=1, nswps - call prec%precv(1)%sm%apply(sone,x,szero,ww,desc_data,trans_,& - & ione, work_,info) - call prec%precv(1)%sm2a%apply(sone,ww,szero,x,desc_data,trans_,& - & ione, work_,info) - end do - case('T','C') - do k=1, nswps - call prec%precv(1)%sm2a%apply(sone,x,szero,ww,desc_data,trans_,& - & ione, work_,info) - call prec%precv(1)%sm%apply(sone,ww,szero,x,desc_data,trans_,& - & ione, work_,info) - end do - case default - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Invalid trans') - goto 9999 - end select - - else - call prec%precv(1)%sm%apply(sone,x,szero,ww,desc_data,trans_,& - & nswps, work_,info) + call mld_mlprec_aply(sone,prec,x,szero,ww,desc_data,trans_,work_,info) if (info == 0) call psb_geaxpby(sone,ww,szero,x,desc_data,info) - end if - else + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_smlprec_aply') + goto 9999 + end if - info = psb_err_from_subroutine_ai_ - call psb_errpush(info,name,a_err='Invalid size of precv',& - & i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/)) - goto 9999 - endif + else if (size(prec%precv) == 1) then + ! + ! Number of levels = 1: apply the base preconditioner + ! + nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post) + if (allocated(prec%precv(1)%sm2a)) then + ! + ! This is a kludge for handling the symmetrized GS case. + ! Will need some rethinking. + ! + select case(trans_) + case ('N') + do k=1, nswps + call prec%precv(1)%sm%apply(sone,x,szero,ww,desc_data,trans_,& + & ione, work_,wv,info) + call prec%precv(1)%sm2a%apply(sone,ww,szero,x,desc_data,trans_,& + & ione, work_,wv,info) + end do + case('T','C') + do k=1, nswps + call prec%precv(1)%sm2a%apply(sone,x,szero,ww,desc_data,trans_,& + & ione, work_,wv,info) + call prec%precv(1)%sm%apply(sone,ww,szero,x,desc_data,trans_,& + & ione, work_,wv,info) + end do + case default + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Invalid trans') + goto 9999 + end select - if (info == 0) call psb_gefree(ww,desc_data,info) + else + call prec%precv(1)%sm%apply(sone,x,szero,ww,desc_data,trans_,& + & nswps, work_,wv,info) + if (info == 0) call psb_geaxpby(sone,ww,szero,x,desc_data,info) + end if + else + + info = psb_err_from_subroutine_ai_ + call psb_errpush(info,name,a_err='Invalid size of precv',& + & i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/)) + 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_) diff --git a/mlprec/impl/mld_sprecset.F90 b/mlprec/impl/mld_sprecset.F90 index 688757d4..f8507f94 100644 --- a/mlprec/impl/mld_sprecset.F90 +++ b/mlprec/impl/mld_sprecset.F90 @@ -432,7 +432,7 @@ subroutine mld_sprecsetsm(p,val,info,ilev,ilmax,pos) ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin_, ilmax_ - character(len=*), parameter :: name='mld_precseti' + character(len=*), parameter :: name='mld_precsetsm' info = psb_success_ @@ -495,7 +495,7 @@ subroutine mld_sprecsetsv(p,val,info,ilev,ilmax,pos) ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin_, ilmax_ - character(len=*), parameter :: name='mld_precseti' + character(len=*), parameter :: name='mld_precsetsv' info = psb_success_ diff --git a/mlprec/impl/mld_zmlprec_aply.f90 b/mlprec/impl/mld_zmlprec_aply.f90 index 372b6835..920ba17f 100644 --- a/mlprec/impl/mld_zmlprec_aply.f90 +++ b/mlprec/impl/mld_zmlprec_aply.f90 @@ -255,7 +255,8 @@ subroutine mld_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv(:)) ! ! At first iteration we must use the input BETA ! @@ -482,7 +483,8 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv) if (allocated(p%precv(level)%sm2a)) then call psb_geaxpby(zone,& @@ -494,12 +496,12 @@ contains call p%precv(level)%sm%apply(zone,& & vy2l,zzero,vty,& & base_desc, trans,& - & ione,work,info,init='Z') + & ione,work,wv,info,init='Z') call p%precv(level)%sm2a%apply(zone,& & vty,zzero,vy2l,& & base_desc, trans,& - & ione,work,info,init='Z') + & ione,work,wv,info,init='Z') end do else @@ -507,7 +509,7 @@ contains call p%precv(level)%sm%apply(zone,& & vx2l,zzero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -519,7 +521,8 @@ contains ! Apply the restriction call psb_map_X2Y(zone,vx2l,& & zzero,p%precv(level+1)%wrk%vx2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') @@ -538,7 +541,8 @@ contains ! call psb_map_Y2X(zone,p%precv(level+1)%wrk%vy2l,& & zone,vy2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during prolongation') @@ -605,7 +609,8 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv) if (level < nlev) then ! ! Apply the first smoother @@ -618,13 +623,13 @@ contains if (info == psb_success_) call p%precv(level)%sm%apply(zone,& & vx2l,zzero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& & vx2l,zzero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then @@ -651,7 +656,8 @@ contains end if call psb_map_X2Y(zone,vty,& & zzero,p%precv(level+1)%wrk%vx2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') @@ -661,7 +667,8 @@ contains ! Shortcut: just transfer x2l. call psb_map_X2Y(zone,vx2l,& & zzero,p%precv(level+1)%wrk%vx2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during restriction') @@ -676,7 +683,8 @@ contains ! call psb_map_Y2X(zone,p%precv(level+1)%wrk%vy2l,& & zone,vy2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during prolongation') @@ -693,7 +701,8 @@ contains & base_desc,info,work=work,trans=trans) if (info == psb_success_) call psb_map_X2Y(zone,vty,& & zzero,p%precv(level+1)%wrk%vx2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during W-cycle restriction') @@ -704,7 +713,8 @@ contains if (info == psb_success_) call psb_map_Y2X(zone,p%precv(level+1)%wrk%vy2l,& & zone,vy2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -737,13 +747,13 @@ contains if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& & vty,zone,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& & vty,zone,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then @@ -760,7 +770,7 @@ contains if (info == psb_success_) call p%precv(level)%sm%apply(zone,& & vx2l,zzero,vy2l,& & base_desc, trans,& - & sweeps,work,info) + & sweeps,work,wv,info) else @@ -836,7 +846,8 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv) if (level == nlev) then ! ! Apply smoother @@ -845,7 +856,7 @@ contains if (info == psb_success_) call p%precv(level)%sm%apply(zone,& & vx2l,zzero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else if (level < nlev) then @@ -854,13 +865,13 @@ contains if (info == psb_success_) call p%precv(level)%sm%apply(zone,& & vx2l,zzero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& & vx2l,zzero,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then @@ -890,7 +901,8 @@ contains ! Apply the restriction call psb_map_X2Y(zone,vty,& & zzero,p%precv(level + 1)%wrk%vx2l,& - & p%precv(level + 1)%map,info,work=work) + & p%precv(level + 1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -925,7 +937,8 @@ contains ! call psb_map_Y2X(zone,p%precv(level+1)%wrk%vy2l,& & zone,vy2l,& - & p%precv(level+1)%map,info,work=work) + & p%precv(level+1)%map,info,work=work,& + & vtx=wv(1),vty=wv(2)) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -955,13 +968,13 @@ contains if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& & vty,zone,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& & vty,zone,vy2l,& & base_desc, trans,& - & sweeps,work,info,init='Z') + & sweeps,work,wv,info,init='Z') end if if (info /= psb_success_) then @@ -1014,7 +1027,8 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& - & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc) + & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& + & wv => p%precv(level)%wrk%wv) !Assemble rhs, w, v, v1, x diff --git a/mlprec/impl/mld_zprecaply.f90 b/mlprec/impl/mld_zprecaply.f90 index 80328261..2bb8a55c 100644 --- a/mlprec/impl/mld_zprecaply.f90 +++ b/mlprec/impl/mld_zprecaply.f90 @@ -323,6 +323,7 @@ subroutine mld_zprecaply2_vect(prec,x,y,desc_data,info,trans,work) complex(psb_dpk_), pointer :: work_(:) integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: err_act,iwsz, k, nswps + logical :: do_alloc_wrk character(len=20) :: name name='mld_zprecaply' @@ -358,6 +359,10 @@ subroutine mld_zprecaply2_vect(prec,x,y,desc_data,info,trans,work) call psb_errpush(info,name) goto 9999 end if + + do_alloc_wrk = .not.allocated(prec%wrk) + if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) + if (size(prec%precv) >1) then ! ! Number of levels > 1: apply the multilevel preconditioner @@ -375,31 +380,29 @@ subroutine mld_zprecaply2_vect(prec,x,y,desc_data,info,trans,work) ! nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post) - if (allocated(prec%precv(1)%sm2a)) then - ! - ! This is a kludge for handling the symmetrized GS case. - ! Will need some rethinking. - ! - twoside: block - type(psb_z_vect_type) :: w1,w2 - call psb_geasb(w1,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(w2,desc_data,info,mold=x%v,scratch=.true.) + associate(w1 => prec%precv(1)%wrk%vx2l, w2 => prec%precv(1)%wrk%vy2l,& + & wv => prec%precv(1)%wrk%wv) + if (allocated(prec%precv(1)%sm2a)) then + ! + ! This is a kludge for handling the symmetrized GS case. + ! Will need some rethinking. + ! call psb_geaxpby(zone,x,zzero,w1,desc_data,info) select case(trans_) case ('N') do k=1, nswps call prec%precv(1)%sm%apply(zone,w1,zzero,w2,desc_data,trans_,& - & ione, work_,info) + & ione, work_,wv,info) call prec%precv(1)%sm2a%apply(zone,w2,zzero,w1,desc_data,trans_,& - & ione, work_,info) + & ione, work_,wv,info) end do - + case('T','C') do k=1, nswps call prec%precv(1)%sm2a%apply(zone,w1,zzero,w2,desc_data,trans_,& - & ione, work_,info) + & ione, work_,wv,info) call prec%precv(1)%sm%apply(zone,w2,zzero,w1,desc_data,trans_,& - & ione, work_,info) + & ione, work_,wv,info) end do case default info = psb_err_from_subroutine_ @@ -407,14 +410,12 @@ subroutine mld_zprecaply2_vect(prec,x,y,desc_data,info,trans,work) goto 9999 end select call psb_geaxpby(zone,w1,zzero,y,desc_data,info) - call psb_gefree(w1,desc_data,info) - call psb_gefree(w2,desc_data,info) - end block twoside - - else - call prec%precv(1)%sm%apply(zone,x,zzero,y,desc_data,trans_,& - & nswps,work_,info) - end if + else + call prec%precv(1)%sm%apply(zone,x,zzero,y,desc_data,trans_,& + & nswps,work_,wv,info) + end if + end associate + else info = psb_err_from_subroutine_ai_ @@ -426,6 +427,7 @@ subroutine mld_zprecaply2_vect(prec,x,y,desc_data,info,trans,work) ! If the original distribution has an overlap we should fix that. call psb_halo(y,desc_data,info,data=psb_comm_mov_) + if (do_alloc_wrk) call prec%free_wrk(info) if (present(work)) then else @@ -459,10 +461,10 @@ subroutine mld_zprecaply1_vect(prec,x,desc_data,info,trans,work) ! Local variables character :: trans_ - type(psb_z_vect_type) :: ww complex(psb_dpk_), pointer :: work_(:) integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: err_act,iwsz, k, nswps + logical :: do_alloc_wrk character(len=20) :: name name='mld_zprecaply' @@ -498,63 +500,68 @@ subroutine mld_zprecaply1_vect(prec,x,desc_data,info,trans,work) call psb_errpush(info,name) goto 9999 end if - 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 - ! - call mld_mlprec_aply(zone,prec,x,zzero,ww,desc_data,trans_,work_,info) - if (info == 0) call psb_geaxpby(zone,ww,zzero,x,desc_data,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_zmlprec_aply') - goto 9999 - end if + + do_alloc_wrk = .not.allocated(prec%wrk) + if (do_alloc_wrk) call prec%allocate_wrk(info,vmold=x%v) - else if (size(prec%precv) == 1) then - ! - ! Number of levels = 1: apply the base preconditioner - ! - nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post) - if (allocated(prec%precv(1)%sm2a)) then + 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 ! - ! This is a kludge for handling the symmetrized GS case. - ! Will need some rethinking. + ! Number of levels > 1: apply the multilevel preconditioner ! - select case(trans_) - case ('N') - do k=1, nswps - call prec%precv(1)%sm%apply(zone,x,zzero,ww,desc_data,trans_,& - & ione, work_,info) - call prec%precv(1)%sm2a%apply(zone,ww,zzero,x,desc_data,trans_,& - & ione, work_,info) - end do - case('T','C') - do k=1, nswps - call prec%precv(1)%sm2a%apply(zone,x,zzero,ww,desc_data,trans_,& - & ione, work_,info) - call prec%precv(1)%sm%apply(zone,ww,zzero,x,desc_data,trans_,& - & ione, work_,info) - end do - case default - info = psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Invalid trans') - goto 9999 - end select - - else - call prec%precv(1)%sm%apply(zone,x,zzero,ww,desc_data,trans_,& - & nswps, work_,info) + call mld_mlprec_aply(zone,prec,x,zzero,ww,desc_data,trans_,work_,info) if (info == 0) call psb_geaxpby(zone,ww,zzero,x,desc_data,info) - end if - else + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_zmlprec_aply') + goto 9999 + end if - info = psb_err_from_subroutine_ai_ - call psb_errpush(info,name,a_err='Invalid size of precv',& - & i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/)) - goto 9999 - endif + else if (size(prec%precv) == 1) then + ! + ! Number of levels = 1: apply the base preconditioner + ! + nswps = max(prec%precv(1)%parms%sweeps_pre,prec%precv(1)%parms%sweeps_post) + if (allocated(prec%precv(1)%sm2a)) then + ! + ! This is a kludge for handling the symmetrized GS case. + ! Will need some rethinking. + ! + select case(trans_) + case ('N') + do k=1, nswps + call prec%precv(1)%sm%apply(zone,x,zzero,ww,desc_data,trans_,& + & ione, work_,wv,info) + call prec%precv(1)%sm2a%apply(zone,ww,zzero,x,desc_data,trans_,& + & ione, work_,wv,info) + end do + case('T','C') + do k=1, nswps + call prec%precv(1)%sm2a%apply(zone,x,zzero,ww,desc_data,trans_,& + & ione, work_,wv,info) + call prec%precv(1)%sm%apply(zone,ww,zzero,x,desc_data,trans_,& + & ione, work_,wv,info) + end do + case default + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Invalid trans') + goto 9999 + end select - if (info == 0) call psb_gefree(ww,desc_data,info) + else + call prec%precv(1)%sm%apply(zone,x,zzero,ww,desc_data,trans_,& + & nswps, work_,wv,info) + if (info == 0) call psb_geaxpby(zone,ww,zzero,x,desc_data,info) + end if + else + + info = psb_err_from_subroutine_ai_ + call psb_errpush(info,name,a_err='Invalid size of precv',& + & i_Err=(/ione*size(prec%precv),izero,izero,izero,izero/)) + 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_) diff --git a/mlprec/impl/mld_zprecset.F90 b/mlprec/impl/mld_zprecset.F90 index 4226b812..f5df9866 100644 --- a/mlprec/impl/mld_zprecset.F90 +++ b/mlprec/impl/mld_zprecset.F90 @@ -465,7 +465,7 @@ subroutine mld_zprecsetsm(p,val,info,ilev,ilmax,pos) ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin_, ilmax_ - character(len=*), parameter :: name='mld_precseti' + character(len=*), parameter :: name='mld_precsetsm' info = psb_success_ @@ -528,7 +528,7 @@ subroutine mld_zprecsetsv(p,val,info,ilev,ilmax,pos) ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin_, ilmax_ - character(len=*), parameter :: name='mld_precseti' + character(len=*), parameter :: name='mld_precsetsv' info = psb_success_ diff --git a/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 index fa3d666a..6fc4ae38 100644 --- a/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu,wv) + & sweeps,work,wv,info,init,initu) use psb_base_mod use mld_c_as_smoother, mld_protect_nam => mld_c_as_smoother_apply_vect implicit none @@ -48,10 +48,10 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu - type(psb_c_vect_type),intent(inout), optional :: wv(:) integer(psb_ipk_) :: n_row,n_col, nrow_d, i complex(psb_spk_), pointer :: aux(:) @@ -125,88 +125,95 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! to compute an approximate solution of a linear system. ! ! - call psb_geasb(tx,sm%desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(ty,sm%desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(ww,sm%desc_data,info,mold=x%v,scratch=.true.) - ! Need to zero tx because of the apply_restr call. - call tx%zero() - ! - ! Unroll the first iteration and fold it inside SELECT CASE - ! this will save one SPMM when INIT=Z, and will be - ! significant when sweeps=1 (a common case) - ! - call psb_geaxpby(cone,x,czero,tx,desc_data,info) - if (info == 0) call sm%apply_restr(tx,trans_,aux,info) - if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info) - - select case (init_) - case('Z') - call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Z') - - case('Y') - call psb_geaxpby(cone,y,czero,ty,desc_data,info) - if (info == 0) call sm%apply_restr(ty,trans_,aux,info) - if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,& - & work=aux,trans=trans_) - call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y') - - case('U') - if (.not.present(initu)) then + if (size(wv) < 3) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='missing initu to smoother_apply') - goto 9999 - end if - call psb_geaxpby(cone,initu,czero,ty,desc_data,info) - if (info == 0) call sm%apply_restr(ty,trans_,aux,info) - if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,& - & work=aux,trans=trans_) - call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y') - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong init to smoother_apply') - goto 9999 - end select - if (info == 0) call sm%apply_prol(ty,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') + & a_err='invalid wv size in smoother_apply') goto 9999 - endif - - do i=1, sweeps-1 + end if + associate(tx => wv(1), ty => wv(2), ww => wv(3)) + +!!$ call psb_geasb(tx,sm%desc_data,info,mold=x%v,scratch=.true.) +!!$ call psb_geasb(ty,sm%desc_data,info,mold=x%v,scratch=.true.) +!!$ call psb_geasb(ww,sm%desc_data,info,mold=x%v,scratch=.true.) + ! Need to zero tx because of the apply_restr call. + call tx%zero() ! - ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the - ! block diagonal part and the remaining part of the local matrix - ! and Y(j) is the approximate solution at sweep j. + ! Unroll the first iteration and fold it inside SELECT CASE + ! this will save one SPMM when INIT=Z, and will be + ! significant when sweeps=1 (a common case) ! + call psb_geaxpby(cone,x,czero,tx,desc_data,info) + if (info == 0) call sm%apply_restr(tx,trans_,aux,info) if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info) - if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,& - & work=aux,trans=trans_) - - if (info /= psb_success_) exit - - call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Y') - - if (info /= psb_success_) exit + + select case (init_) + case('Z') + call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Z') + + case('Y') + call psb_geaxpby(cone,y,czero,ty,desc_data,info) + if (info == 0) call sm%apply_restr(ty,trans_,aux,info) + if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,& + & work=aux,trans=trans_) + call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y') + + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(cone,initu,czero,ty,desc_data,info) + if (info == 0) call sm%apply_restr(ty,trans_,aux,info) + if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,& + & work=aux,trans=trans_) + call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y') + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select if (info == 0) call sm%apply_prol(ty,trans_,aux,info) - - end do - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 - end if - - ! - ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) - ! - call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - - + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + do i=1, sweeps-1 + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + if (info == 0) call psb_geaxpby(cone,tx,czero,ww,sm%desc_data,info) + if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,& + & work=aux,trans=trans_) + + if (info /= psb_success_) exit + + call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Y') + + if (info /= psb_success_) exit + if (info == 0) call sm%apply_prol(ty,trans_,aux,info) + + end do + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + ! + ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) + ! + call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + end associate + else info = psb_err_iarg_neg_ @@ -220,9 +227,9 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (.not.(4*isz <= size(work))) then deallocate(aux,stat=info) endif - if (info ==0) call ww%free(info) - if (info ==0) call tx%free(info) - if (info ==0) call ty%free(info) +!!$ if (info ==0) call ww%free(info) +!!$ if (info ==0) call tx%free(info) +!!$ if (info ==0) call ty%free(info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) diff --git a/mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 index cc7eb484..9015b07c 100644 --- a/mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu,wv) + & trans,sweeps,work,wv,info,init,initu) use psb_base_mod use mld_c_base_smoother_mod, mld_protect_name => mld_c_base_smoother_apply_vect implicit none @@ -48,10 +48,10 @@ subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu - type(psb_c_vect_type),intent(inout), optional :: wv(:) ! integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_smoother_apply' diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 index ce9d45f7..5e393745 100644 --- a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu,wv) + & sweeps,work,wv,info,init,initu) use psb_base_mod use mld_c_jac_smoother, mld_protect_name => mld_c_jac_smoother_apply_vect @@ -49,10 +49,10 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu - type(psb_c_vect_type),intent(inout), optional :: wv(:) ! integer(psb_ipk_) :: n_row,n_col type(psb_c_vect_type) :: tx, ty @@ -122,77 +122,86 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! to compute an approximate solution of a linear system. ! ! - call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.) + if (size(wv) < 2) then + info = psb_err_internal_error_ + write(0,*) 'Size (WV) : ',size(wv) + call psb_errpush(info,name,& + & a_err='invalid wv size in smoother_apply') + goto 9999 + end if + associate(tx => wv(1), ty => wv(2)) +!!$ call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.) +!!$ call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.) - ! - ! Unroll the first iteration and fold it inside SELECT CASE - ! this will save one AXPBY and one SPMM when INIT=Z, and will be - ! significant when sweeps=1 (a common case) - ! - select case (init_) - case('Z') - - call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,info,init='Z') - - case('Y') - call psb_geaxpby(cone,x,czero,tx,desc_data,info) - call psb_geaxpby(cone,y,czero,ty,desc_data,info) - call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') - - case('U') - if (.not.present(initu)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='missing initu to smoother_apply') - goto 9999 - end if - call psb_geaxpby(cone,x,czero,tx,desc_data,info) - call psb_geaxpby(cone,initu,czero,ty,desc_data,info) - call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong init to smoother_apply') - goto 9999 - end select - - do i=1, sweeps-1 ! - ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the - ! block diagonal part and the remaining part of the local matrix - ! and Y(j) is the approximate solution at sweep j. + ! Unroll the first iteration and fold it inside SELECT CASE + ! this will save one AXPBY and one SPMM when INIT=Z, and will be + ! significant when sweeps=1 (a common case) ! - call psb_geaxpby(cone,x,czero,tx,desc_data,info) - call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_) + select case (init_) + case('Z') + + call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,info,init='Z') + + case('Y') + call psb_geaxpby(cone,x,czero,tx,desc_data,info) + call psb_geaxpby(cone,y,czero,ty,desc_data,info) + call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_) + call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') + + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(cone,x,czero,tx,desc_data,info) + call psb_geaxpby(cone,initu,czero,ty,desc_data,info) + call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_) + call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select - if (info /= psb_success_) exit + do i=1, sweeps-1 + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + call psb_geaxpby(cone,x,czero,tx,desc_data,info) + call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') + if (info /= psb_success_) exit - if (info /= psb_success_) exit - end do + call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') - if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + if (info /= psb_success_) exit + end do - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 - end if + if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - call tx%free(info) - if (info == psb_success_) call ty%free(info) - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='final cleanup with Jacobi sweeps > 1') - goto 9999 - end if + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if +!!$ call tx%free(info) +!!$ if (info == psb_success_) call ty%free(info) +!!$ if (info /= psb_success_) then +!!$ info=psb_err_internal_error_ +!!$ call psb_errpush(info,name,& +!!$ & a_err='final cleanup with Jacobi sweeps > 1') +!!$ goto 9999 +!!$ end if + end associate + else info = psb_err_iarg_neg_ diff --git a/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 index 08784800..68bae713 100644 --- a/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu,wv) + & sweeps,work,wv,info,init,initu) use psb_base_mod use mld_d_as_smoother, mld_protect_nam => mld_d_as_smoother_apply_vect implicit none @@ -48,10 +48,10 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu - type(psb_d_vect_type),intent(inout), optional :: wv(:) integer(psb_ipk_) :: n_row,n_col, nrow_d, i real(psb_dpk_), pointer :: aux(:) @@ -125,88 +125,95 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! to compute an approximate solution of a linear system. ! ! - call psb_geasb(tx,sm%desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(ty,sm%desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(ww,sm%desc_data,info,mold=x%v,scratch=.true.) - ! Need to zero tx because of the apply_restr call. - call tx%zero() - ! - ! Unroll the first iteration and fold it inside SELECT CASE - ! this will save one SPMM when INIT=Z, and will be - ! significant when sweeps=1 (a common case) - ! - call psb_geaxpby(done,x,dzero,tx,desc_data,info) - if (info == 0) call sm%apply_restr(tx,trans_,aux,info) - if (info == 0) call psb_geaxpby(done,tx,dzero,ww,sm%desc_data,info) - - select case (init_) - case('Z') - call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info,init='Z') - - case('Y') - call psb_geaxpby(done,y,dzero,ty,desc_data,info) - if (info == 0) call sm%apply_restr(ty,trans_,aux,info) - if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,& - & work=aux,trans=trans_) - call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,info,init='Y') - - case('U') - if (.not.present(initu)) then + if (size(wv) < 3) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='missing initu to smoother_apply') - goto 9999 - end if - call psb_geaxpby(done,initu,dzero,ty,desc_data,info) - if (info == 0) call sm%apply_restr(ty,trans_,aux,info) - if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,& - & work=aux,trans=trans_) - call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,info,init='Y') - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong init to smoother_apply') - goto 9999 - end select - if (info == 0) call sm%apply_prol(ty,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') + & a_err='invalid wv size in smoother_apply') goto 9999 - endif - - do i=1, sweeps-1 + end if + associate(tx => wv(1), ty => wv(2), ww => wv(3)) + +!!$ call psb_geasb(tx,sm%desc_data,info,mold=x%v,scratch=.true.) +!!$ call psb_geasb(ty,sm%desc_data,info,mold=x%v,scratch=.true.) +!!$ call psb_geasb(ww,sm%desc_data,info,mold=x%v,scratch=.true.) + ! Need to zero tx because of the apply_restr call. + call tx%zero() ! - ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the - ! block diagonal part and the remaining part of the local matrix - ! and Y(j) is the approximate solution at sweep j. + ! Unroll the first iteration and fold it inside SELECT CASE + ! this will save one SPMM when INIT=Z, and will be + ! significant when sweeps=1 (a common case) ! + call psb_geaxpby(done,x,dzero,tx,desc_data,info) + if (info == 0) call sm%apply_restr(tx,trans_,aux,info) if (info == 0) call psb_geaxpby(done,tx,dzero,ww,sm%desc_data,info) - if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,& - & work=aux,trans=trans_) - - if (info /= psb_success_) exit - - call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info,init='Y') - - if (info /= psb_success_) exit + + select case (init_) + case('Z') + call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info,init='Z') + + case('Y') + call psb_geaxpby(done,y,dzero,ty,desc_data,info) + if (info == 0) call sm%apply_restr(ty,trans_,aux,info) + if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,& + & work=aux,trans=trans_) + call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,info,init='Y') + + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(done,initu,dzero,ty,desc_data,info) + if (info == 0) call sm%apply_restr(ty,trans_,aux,info) + if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,& + & work=aux,trans=trans_) + call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,info,init='Y') + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select if (info == 0) call sm%apply_prol(ty,trans_,aux,info) - - end do - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 - end if - - ! - ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) - ! - call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - - + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + do i=1, sweeps-1 + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + if (info == 0) call psb_geaxpby(done,tx,dzero,ww,sm%desc_data,info) + if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,& + & work=aux,trans=trans_) + + if (info /= psb_success_) exit + + call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info,init='Y') + + if (info /= psb_success_) exit + if (info == 0) call sm%apply_prol(ty,trans_,aux,info) + + end do + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + ! + ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) + ! + call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + end associate + else info = psb_err_iarg_neg_ @@ -220,9 +227,9 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (.not.(4*isz <= size(work))) then deallocate(aux,stat=info) endif - if (info ==0) call ww%free(info) - if (info ==0) call tx%free(info) - if (info ==0) call ty%free(info) +!!$ if (info ==0) call ww%free(info) +!!$ if (info ==0) call tx%free(info) +!!$ if (info ==0) call ty%free(info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) diff --git a/mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 index 2033b7a0..f153a18a 100644 --- a/mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu,wv) + & trans,sweeps,work,wv,info,init,initu) use psb_base_mod use mld_d_base_smoother_mod, mld_protect_name => mld_d_base_smoother_apply_vect implicit none @@ -48,10 +48,10 @@ subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu - type(psb_d_vect_type),intent(inout), optional :: wv(:) ! integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_smoother_apply' diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 index 280bc233..c5d2b002 100644 --- a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu,wv) + & sweeps,work,wv,info,init,initu) use psb_base_mod use mld_d_jac_smoother, mld_protect_name => mld_d_jac_smoother_apply_vect @@ -49,10 +49,10 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu - type(psb_d_vect_type),intent(inout), optional :: wv(:) ! integer(psb_ipk_) :: n_row,n_col type(psb_d_vect_type) :: tx, ty @@ -122,77 +122,86 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! to compute an approximate solution of a linear system. ! ! - call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.) + if (size(wv) < 2) then + info = psb_err_internal_error_ + write(0,*) 'Size (WV) : ',size(wv) + call psb_errpush(info,name,& + & a_err='invalid wv size in smoother_apply') + goto 9999 + end if + associate(tx => wv(1), ty => wv(2)) +!!$ call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.) +!!$ call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.) - ! - ! Unroll the first iteration and fold it inside SELECT CASE - ! this will save one AXPBY and one SPMM when INIT=Z, and will be - ! significant when sweeps=1 (a common case) - ! - select case (init_) - case('Z') - - call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,info,init='Z') - - case('Y') - call psb_geaxpby(done,x,dzero,tx,desc_data,info) - call psb_geaxpby(done,y,dzero,ty,desc_data,info) - call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y') - - case('U') - if (.not.present(initu)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='missing initu to smoother_apply') - goto 9999 - end if - call psb_geaxpby(done,x,dzero,tx,desc_data,info) - call psb_geaxpby(done,initu,dzero,ty,desc_data,info) - call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y') - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong init to smoother_apply') - goto 9999 - end select - - do i=1, sweeps-1 ! - ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the - ! block diagonal part and the remaining part of the local matrix - ! and Y(j) is the approximate solution at sweep j. + ! Unroll the first iteration and fold it inside SELECT CASE + ! this will save one AXPBY and one SPMM when INIT=Z, and will be + ! significant when sweeps=1 (a common case) ! - call psb_geaxpby(done,x,dzero,tx,desc_data,info) - call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) + select case (init_) + case('Z') + + call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,info,init='Z') + + case('Y') + call psb_geaxpby(done,x,dzero,tx,desc_data,info) + call psb_geaxpby(done,y,dzero,ty,desc_data,info) + call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) + call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y') + + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(done,x,dzero,tx,desc_data,info) + call psb_geaxpby(done,initu,dzero,ty,desc_data,info) + call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) + call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y') + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select - if (info /= psb_success_) exit + do i=1, sweeps-1 + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + call psb_geaxpby(done,x,dzero,tx,desc_data,info) + call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y') + if (info /= psb_success_) exit - if (info /= psb_success_) exit - end do + call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y') - if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + if (info /= psb_success_) exit + end do - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 - end if + if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - call tx%free(info) - if (info == psb_success_) call ty%free(info) - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='final cleanup with Jacobi sweeps > 1') - goto 9999 - end if + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if +!!$ call tx%free(info) +!!$ if (info == psb_success_) call ty%free(info) +!!$ if (info /= psb_success_) then +!!$ info=psb_err_internal_error_ +!!$ call psb_errpush(info,name,& +!!$ & a_err='final cleanup with Jacobi sweeps > 1') +!!$ goto 9999 +!!$ end if + end associate + else info = psb_err_iarg_neg_ diff --git a/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 index 1e12bff5..ecfcd54b 100644 --- a/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu,wv) + & sweeps,work,wv,info,init,initu) use psb_base_mod use mld_s_as_smoother, mld_protect_nam => mld_s_as_smoother_apply_vect implicit none @@ -48,10 +48,10 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu - type(psb_s_vect_type),intent(inout), optional :: wv(:) integer(psb_ipk_) :: n_row,n_col, nrow_d, i real(psb_spk_), pointer :: aux(:) @@ -125,88 +125,95 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! to compute an approximate solution of a linear system. ! ! - call psb_geasb(tx,sm%desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(ty,sm%desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(ww,sm%desc_data,info,mold=x%v,scratch=.true.) - ! Need to zero tx because of the apply_restr call. - call tx%zero() - ! - ! Unroll the first iteration and fold it inside SELECT CASE - ! this will save one SPMM when INIT=Z, and will be - ! significant when sweeps=1 (a common case) - ! - call psb_geaxpby(sone,x,szero,tx,desc_data,info) - if (info == 0) call sm%apply_restr(tx,trans_,aux,info) - if (info == 0) call psb_geaxpby(sone,tx,szero,ww,sm%desc_data,info) - - select case (init_) - case('Z') - call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info,init='Z') - - case('Y') - call psb_geaxpby(sone,y,szero,ty,desc_data,info) - if (info == 0) call sm%apply_restr(ty,trans_,aux,info) - if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,& - & work=aux,trans=trans_) - call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,info,init='Y') - - case('U') - if (.not.present(initu)) then + if (size(wv) < 3) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='missing initu to smoother_apply') - goto 9999 - end if - call psb_geaxpby(sone,initu,szero,ty,desc_data,info) - if (info == 0) call sm%apply_restr(ty,trans_,aux,info) - if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,& - & work=aux,trans=trans_) - call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,info,init='Y') - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong init to smoother_apply') - goto 9999 - end select - if (info == 0) call sm%apply_prol(ty,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') + & a_err='invalid wv size in smoother_apply') goto 9999 - endif - - do i=1, sweeps-1 + end if + associate(tx => wv(1), ty => wv(2), ww => wv(3)) + +!!$ call psb_geasb(tx,sm%desc_data,info,mold=x%v,scratch=.true.) +!!$ call psb_geasb(ty,sm%desc_data,info,mold=x%v,scratch=.true.) +!!$ call psb_geasb(ww,sm%desc_data,info,mold=x%v,scratch=.true.) + ! Need to zero tx because of the apply_restr call. + call tx%zero() ! - ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the - ! block diagonal part and the remaining part of the local matrix - ! and Y(j) is the approximate solution at sweep j. + ! Unroll the first iteration and fold it inside SELECT CASE + ! this will save one SPMM when INIT=Z, and will be + ! significant when sweeps=1 (a common case) ! + call psb_geaxpby(sone,x,szero,tx,desc_data,info) + if (info == 0) call sm%apply_restr(tx,trans_,aux,info) if (info == 0) call psb_geaxpby(sone,tx,szero,ww,sm%desc_data,info) - if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,& - & work=aux,trans=trans_) - - if (info /= psb_success_) exit - - call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info,init='Y') - - if (info /= psb_success_) exit + + select case (init_) + case('Z') + call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info,init='Z') + + case('Y') + call psb_geaxpby(sone,y,szero,ty,desc_data,info) + if (info == 0) call sm%apply_restr(ty,trans_,aux,info) + if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,& + & work=aux,trans=trans_) + call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,info,init='Y') + + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(sone,initu,szero,ty,desc_data,info) + if (info == 0) call sm%apply_restr(ty,trans_,aux,info) + if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,& + & work=aux,trans=trans_) + call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,info,init='Y') + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select if (info == 0) call sm%apply_prol(ty,trans_,aux,info) - - end do - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 - end if - - ! - ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) - ! - call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - - + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + do i=1, sweeps-1 + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + if (info == 0) call psb_geaxpby(sone,tx,szero,ww,sm%desc_data,info) + if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,& + & work=aux,trans=trans_) + + if (info /= psb_success_) exit + + call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info,init='Y') + + if (info /= psb_success_) exit + if (info == 0) call sm%apply_prol(ty,trans_,aux,info) + + end do + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + ! + ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) + ! + call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + end associate + else info = psb_err_iarg_neg_ @@ -220,9 +227,9 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (.not.(4*isz <= size(work))) then deallocate(aux,stat=info) endif - if (info ==0) call ww%free(info) - if (info ==0) call tx%free(info) - if (info ==0) call ty%free(info) +!!$ if (info ==0) call ww%free(info) +!!$ if (info ==0) call tx%free(info) +!!$ if (info ==0) call ty%free(info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) diff --git a/mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 index 031b52e4..c3fb485e 100644 --- a/mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu,wv) + & trans,sweeps,work,wv,info,init,initu) use psb_base_mod use mld_s_base_smoother_mod, mld_protect_name => mld_s_base_smoother_apply_vect implicit none @@ -48,10 +48,10 @@ subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu - type(psb_s_vect_type),intent(inout), optional :: wv(:) ! integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_smoother_apply' diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 index 24f81fa7..64927b4e 100644 --- a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu,wv) + & sweeps,work,wv,info,init,initu) use psb_base_mod use mld_s_jac_smoother, mld_protect_name => mld_s_jac_smoother_apply_vect @@ -49,10 +49,10 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu - type(psb_s_vect_type),intent(inout), optional :: wv(:) ! integer(psb_ipk_) :: n_row,n_col type(psb_s_vect_type) :: tx, ty @@ -122,77 +122,86 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! to compute an approximate solution of a linear system. ! ! - call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.) + if (size(wv) < 2) then + info = psb_err_internal_error_ + write(0,*) 'Size (WV) : ',size(wv) + call psb_errpush(info,name,& + & a_err='invalid wv size in smoother_apply') + goto 9999 + end if + associate(tx => wv(1), ty => wv(2)) +!!$ call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.) +!!$ call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.) - ! - ! Unroll the first iteration and fold it inside SELECT CASE - ! this will save one AXPBY and one SPMM when INIT=Z, and will be - ! significant when sweeps=1 (a common case) - ! - select case (init_) - case('Z') - - call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,info,init='Z') - - case('Y') - call psb_geaxpby(sone,x,szero,tx,desc_data,info) - call psb_geaxpby(sone,y,szero,ty,desc_data,info) - call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y') - - case('U') - if (.not.present(initu)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='missing initu to smoother_apply') - goto 9999 - end if - call psb_geaxpby(sone,x,szero,tx,desc_data,info) - call psb_geaxpby(sone,initu,szero,ty,desc_data,info) - call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y') - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong init to smoother_apply') - goto 9999 - end select - - do i=1, sweeps-1 ! - ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the - ! block diagonal part and the remaining part of the local matrix - ! and Y(j) is the approximate solution at sweep j. + ! Unroll the first iteration and fold it inside SELECT CASE + ! this will save one AXPBY and one SPMM when INIT=Z, and will be + ! significant when sweeps=1 (a common case) ! - call psb_geaxpby(sone,x,szero,tx,desc_data,info) - call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) + select case (init_) + case('Z') + + call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,info,init='Z') + + case('Y') + call psb_geaxpby(sone,x,szero,tx,desc_data,info) + call psb_geaxpby(sone,y,szero,ty,desc_data,info) + call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) + call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y') + + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(sone,x,szero,tx,desc_data,info) + call psb_geaxpby(sone,initu,szero,ty,desc_data,info) + call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) + call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y') + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select - if (info /= psb_success_) exit + do i=1, sweeps-1 + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + call psb_geaxpby(sone,x,szero,tx,desc_data,info) + call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y') + if (info /= psb_success_) exit - if (info /= psb_success_) exit - end do + call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y') - if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + if (info /= psb_success_) exit + end do - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 - end if + if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - call tx%free(info) - if (info == psb_success_) call ty%free(info) - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='final cleanup with Jacobi sweeps > 1') - goto 9999 - end if + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if +!!$ call tx%free(info) +!!$ if (info == psb_success_) call ty%free(info) +!!$ if (info /= psb_success_) then +!!$ info=psb_err_internal_error_ +!!$ call psb_errpush(info,name,& +!!$ & a_err='final cleanup with Jacobi sweeps > 1') +!!$ goto 9999 +!!$ end if + end associate + else info = psb_err_iarg_neg_ diff --git a/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 index c0658c33..ae52866b 100644 --- a/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu,wv) + & sweeps,work,wv,info,init,initu) use psb_base_mod use mld_z_as_smoother, mld_protect_nam => mld_z_as_smoother_apply_vect implicit none @@ -48,10 +48,10 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu - type(psb_z_vect_type),intent(inout), optional :: wv(:) integer(psb_ipk_) :: n_row,n_col, nrow_d, i complex(psb_dpk_), pointer :: aux(:) @@ -125,88 +125,95 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! to compute an approximate solution of a linear system. ! ! - call psb_geasb(tx,sm%desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(ty,sm%desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(ww,sm%desc_data,info,mold=x%v,scratch=.true.) - ! Need to zero tx because of the apply_restr call. - call tx%zero() - ! - ! Unroll the first iteration and fold it inside SELECT CASE - ! this will save one SPMM when INIT=Z, and will be - ! significant when sweeps=1 (a common case) - ! - call psb_geaxpby(zone,x,zzero,tx,desc_data,info) - if (info == 0) call sm%apply_restr(tx,trans_,aux,info) - if (info == 0) call psb_geaxpby(zone,tx,zzero,ww,sm%desc_data,info) - - select case (init_) - case('Z') - call sm%sv%apply(zone,ww,zzero,ty,sm%desc_data,trans_,aux,info,init='Z') - - case('Y') - call psb_geaxpby(zone,y,zzero,ty,desc_data,info) - if (info == 0) call sm%apply_restr(ty,trans_,aux,info) - if (info == 0) call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,& - & work=aux,trans=trans_) - call sm%sv%apply(zone,ww,zzero,ty,desc_data,trans_,aux,info,init='Y') - - case('U') - if (.not.present(initu)) then + if (size(wv) < 3) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='missing initu to smoother_apply') - goto 9999 - end if - call psb_geaxpby(zone,initu,zzero,ty,desc_data,info) - if (info == 0) call sm%apply_restr(ty,trans_,aux,info) - if (info == 0) call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,& - & work=aux,trans=trans_) - call sm%sv%apply(zone,ww,zzero,ty,desc_data,trans_,aux,info,init='Y') - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong init to smoother_apply') - goto 9999 - end select - if (info == 0) call sm%apply_prol(ty,trans_,aux,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in sub_aply Jacobi Sweeps = 1') + & a_err='invalid wv size in smoother_apply') goto 9999 - endif - - do i=1, sweeps-1 + end if + associate(tx => wv(1), ty => wv(2), ww => wv(3)) + +!!$ call psb_geasb(tx,sm%desc_data,info,mold=x%v,scratch=.true.) +!!$ call psb_geasb(ty,sm%desc_data,info,mold=x%v,scratch=.true.) +!!$ call psb_geasb(ww,sm%desc_data,info,mold=x%v,scratch=.true.) + ! Need to zero tx because of the apply_restr call. + call tx%zero() ! - ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the - ! block diagonal part and the remaining part of the local matrix - ! and Y(j) is the approximate solution at sweep j. + ! Unroll the first iteration and fold it inside SELECT CASE + ! this will save one SPMM when INIT=Z, and will be + ! significant when sweeps=1 (a common case) ! + call psb_geaxpby(zone,x,zzero,tx,desc_data,info) + if (info == 0) call sm%apply_restr(tx,trans_,aux,info) if (info == 0) call psb_geaxpby(zone,tx,zzero,ww,sm%desc_data,info) - if (info == 0) call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,& - & work=aux,trans=trans_) - - if (info /= psb_success_) exit - - call sm%sv%apply(zone,ww,zzero,ty,sm%desc_data,trans_,aux,info,init='Y') - - if (info /= psb_success_) exit + + select case (init_) + case('Z') + call sm%sv%apply(zone,ww,zzero,ty,sm%desc_data,trans_,aux,info,init='Z') + + case('Y') + call psb_geaxpby(zone,y,zzero,ty,desc_data,info) + if (info == 0) call sm%apply_restr(ty,trans_,aux,info) + if (info == 0) call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,& + & work=aux,trans=trans_) + call sm%sv%apply(zone,ww,zzero,ty,desc_data,trans_,aux,info,init='Y') + + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(zone,initu,zzero,ty,desc_data,info) + if (info == 0) call sm%apply_restr(ty,trans_,aux,info) + if (info == 0) call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,& + & work=aux,trans=trans_) + call sm%sv%apply(zone,ww,zzero,ty,desc_data,trans_,aux,info,init='Y') + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select if (info == 0) call sm%apply_prol(ty,trans_,aux,info) - - end do - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 - end if - - ! - ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) - ! - call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - - + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in sub_aply Jacobi Sweeps = 1') + goto 9999 + endif + + do i=1, sweeps-1 + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + if (info == 0) call psb_geaxpby(zone,tx,zzero,ww,sm%desc_data,info) + if (info == 0) call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,& + & work=aux,trans=trans_) + + if (info /= psb_success_) exit + + call sm%sv%apply(zone,ww,zzero,ty,sm%desc_data,trans_,aux,info,init='Y') + + if (info /= psb_success_) exit + if (info == 0) call sm%apply_prol(ty,trans_,aux,info) + + end do + + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if + + ! + ! Compute y = beta*y + alpha*ty (ty == K^(-1)*tx) + ! + call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + end associate + else info = psb_err_iarg_neg_ @@ -220,9 +227,9 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (.not.(4*isz <= size(work))) then deallocate(aux,stat=info) endif - if (info ==0) call ww%free(info) - if (info ==0) call tx%free(info) - if (info ==0) call ty%free(info) +!!$ if (info ==0) call ww%free(info) +!!$ if (info ==0) call tx%free(info) +!!$ if (info ==0) call ty%free(info) if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) diff --git a/mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 index c8edb655..18e24b82 100644 --- a/mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu,wv) + & trans,sweeps,work,wv,info,init,initu) use psb_base_mod use mld_z_base_smoother_mod, mld_protect_name => mld_z_base_smoother_apply_vect implicit none @@ -48,10 +48,10 @@ subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu - type(psb_z_vect_type),intent(inout), optional :: wv(:) ! integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_smoother_apply' diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 index 0e61fbab..af0e6488 100644 --- a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu,wv) + & sweeps,work,wv,info,init,initu) use psb_base_mod use mld_z_jac_smoother, mld_protect_name => mld_z_jac_smoother_apply_vect @@ -49,10 +49,10 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu - type(psb_z_vect_type),intent(inout), optional :: wv(:) ! integer(psb_ipk_) :: n_row,n_col type(psb_z_vect_type) :: tx, ty @@ -122,77 +122,86 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! to compute an approximate solution of a linear system. ! ! - call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.) + if (size(wv) < 2) then + info = psb_err_internal_error_ + write(0,*) 'Size (WV) : ',size(wv) + call psb_errpush(info,name,& + & a_err='invalid wv size in smoother_apply') + goto 9999 + end if + associate(tx => wv(1), ty => wv(2)) +!!$ call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.) +!!$ call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.) - ! - ! Unroll the first iteration and fold it inside SELECT CASE - ! this will save one AXPBY and one SPMM when INIT=Z, and will be - ! significant when sweeps=1 (a common case) - ! - select case (init_) - case('Z') - - call sm%sv%apply(zone,x,zzero,ty,desc_data,trans_,aux,info,init='Z') - - case('Y') - call psb_geaxpby(zone,x,zzero,tx,desc_data,info) - call psb_geaxpby(zone,y,zzero,ty,desc_data,info) - call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y') - - case('U') - if (.not.present(initu)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='missing initu to smoother_apply') - goto 9999 - end if - call psb_geaxpby(zone,x,zzero,tx,desc_data,info) - call psb_geaxpby(zone,initu,zzero,ty,desc_data,info) - call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y') - - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong init to smoother_apply') - goto 9999 - end select - - do i=1, sweeps-1 ! - ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the - ! block diagonal part and the remaining part of the local matrix - ! and Y(j) is the approximate solution at sweep j. + ! Unroll the first iteration and fold it inside SELECT CASE + ! this will save one AXPBY and one SPMM when INIT=Z, and will be + ! significant when sweeps=1 (a common case) ! - call psb_geaxpby(zone,x,zzero,tx,desc_data,info) - call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_) + select case (init_) + case('Z') + + call sm%sv%apply(zone,x,zzero,ty,desc_data,trans_,aux,info,init='Z') + + case('Y') + call psb_geaxpby(zone,x,zzero,tx,desc_data,info) + call psb_geaxpby(zone,y,zzero,ty,desc_data,info) + call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_) + call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y') + + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(zone,x,zzero,tx,desc_data,info) + call psb_geaxpby(zone,initu,zzero,ty,desc_data,info) + call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_) + call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y') + + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select - if (info /= psb_success_) exit + do i=1, sweeps-1 + ! + ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the + ! block diagonal part and the remaining part of the local matrix + ! and Y(j) is the approximate solution at sweep j. + ! + call psb_geaxpby(zone,x,zzero,tx,desc_data,info) + call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y') + if (info /= psb_success_) exit - if (info /= psb_success_) exit - end do + call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y') - if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) + if (info /= psb_success_) exit + end do - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='subsolve with Jacobi sweeps > 1') - goto 9999 - end if + if (info == psb_success_) call psb_geaxpby(alpha,ty,beta,y,desc_data,info) - call tx%free(info) - if (info == psb_success_) call ty%free(info) - if (info /= psb_success_) then - info=psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='final cleanup with Jacobi sweeps > 1') - goto 9999 - end if + if (info /= psb_success_) then + info=psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='subsolve with Jacobi sweeps > 1') + goto 9999 + end if +!!$ call tx%free(info) +!!$ if (info == psb_success_) call ty%free(info) +!!$ if (info /= psb_success_) then +!!$ info=psb_err_internal_error_ +!!$ call psb_errpush(info,name,& +!!$ & a_err='final cleanup with Jacobi sweeps > 1') +!!$ goto 9999 +!!$ end if + end associate + else info = psb_err_iarg_neg_ diff --git a/mlprec/mld_c_as_smoother.f90 b/mlprec/mld_c_as_smoother.f90 index c7d5ccd6..5e3f8f4e 100644 --- a/mlprec/mld_c_as_smoother.f90 +++ b/mlprec/mld_c_as_smoother.f90 @@ -181,7 +181,7 @@ module mld_c_as_smoother interface subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu,wv) + & trans,sweeps,work,wv,info,init,initu) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_spk_, mld_c_as_smoother_type, psb_long_int_k_, & & psb_desc_type, psb_ipk_ @@ -194,10 +194,10 @@ module mld_c_as_smoother character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu - type(psb_c_vect_type),intent(inout), optional :: wv(:) end subroutine mld_c_as_smoother_apply_vect end interface diff --git a/mlprec/mld_c_base_smoother_mod.f90 b/mlprec/mld_c_base_smoother_mod.f90 index 9c542cbd..b416bc79 100644 --- a/mlprec/mld_c_base_smoother_mod.f90 +++ b/mlprec/mld_c_base_smoother_mod.f90 @@ -158,7 +158,7 @@ module mld_c_base_smoother_mod interface subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu,wv) + & trans,sweeps,work,wv,info,init,initu) import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & & mld_c_base_smoother_type, psb_ipk_ @@ -170,10 +170,10 @@ module mld_c_base_smoother_mod character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu - type(psb_c_vect_type),intent(inout), optional :: wv(:) end subroutine mld_c_base_smoother_apply_vect end interface diff --git a/mlprec/mld_c_jac_smoother.f90 b/mlprec/mld_c_jac_smoother.f90 index 3b464b6d..1c2221bb 100644 --- a/mlprec/mld_c_jac_smoother.f90 +++ b/mlprec/mld_c_jac_smoother.f90 @@ -85,7 +85,7 @@ module mld_c_jac_smoother interface subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu,wv) + & sweeps,work,wv,info,init,initu) import :: psb_desc_type, mld_c_jac_smoother_type, psb_c_vect_type, psb_spk_, & & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type,& & psb_ipk_ @@ -98,10 +98,10 @@ module mld_c_jac_smoother character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu - type(psb_c_vect_type),intent(inout), optional :: wv(:) end subroutine mld_c_jac_smoother_apply_vect end interface diff --git a/mlprec/mld_c_onelev_mod.f90 b/mlprec/mld_c_onelev_mod.f90 index b76119a3..b4a69b53 100644 --- a/mlprec/mld_c_onelev_mod.f90 +++ b/mlprec/mld_c_onelev_mod.f90 @@ -583,10 +583,9 @@ contains integer(psb_ipk_), intent(out) :: info class(psb_c_base_vect_type), intent(in), optional :: vmold ! - integer(psb_ipk_) :: nwv + integer(psb_ipk_) :: nwv, i info = psb_success_ nwv = lv%get_wrksz() - write(0,*) 'Debug allocate_wrk: ',nwv call psb_geasb(lv%wrk%vx2l,& & lv%base_desc,info,& & scratch=.true.,mold=vmold) @@ -599,7 +598,12 @@ contains call psb_geasb(lv%wrk%vty,& & lv%base_desc,info,& & scratch=.true.,mold=vmold) - + allocate(lv%wrk%wv(nwv),stat=info) + do i=1,nwv + call psb_geasb(lv%wrk%wv(i),& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + end do end subroutine c_base_onelev_allocate_wrk @@ -609,12 +613,17 @@ contains class(mld_c_onelev_type), target, intent(inout) :: lv integer(psb_ipk_), intent(out) :: info ! - integer(psb_ipk_) :: nwv + integer(psb_ipk_) :: nwv,i info = psb_success_ call lv%wrk%vx2l%free(info) call lv%wrk%vy2l%free(info) call lv%wrk%vtx%free(info) call lv%wrk%vty%free(info) + nwv = size(lv%wrk%wv) + do i=1,nwv + call lv%wrk%wv(i)%free(info) + end do + end subroutine c_base_onelev_free_wrk end module mld_c_onelev_mod diff --git a/mlprec/mld_d_as_smoother.f90 b/mlprec/mld_d_as_smoother.f90 index 18d2313c..4ffbbde6 100644 --- a/mlprec/mld_d_as_smoother.f90 +++ b/mlprec/mld_d_as_smoother.f90 @@ -181,7 +181,7 @@ module mld_d_as_smoother interface subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu,wv) + & trans,sweeps,work,wv,info,init,initu) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dpk_, mld_d_as_smoother_type, psb_long_int_k_, & & psb_desc_type, psb_ipk_ @@ -194,10 +194,10 @@ module mld_d_as_smoother character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu - type(psb_d_vect_type),intent(inout), optional :: wv(:) end subroutine mld_d_as_smoother_apply_vect end interface diff --git a/mlprec/mld_d_base_smoother_mod.f90 b/mlprec/mld_d_base_smoother_mod.f90 index b42c96e6..e62fbc16 100644 --- a/mlprec/mld_d_base_smoother_mod.f90 +++ b/mlprec/mld_d_base_smoother_mod.f90 @@ -158,7 +158,7 @@ module mld_d_base_smoother_mod interface subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu,wv) + & trans,sweeps,work,wv,info,init,initu) import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & & mld_d_base_smoother_type, psb_ipk_ @@ -170,10 +170,10 @@ module mld_d_base_smoother_mod character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu - type(psb_d_vect_type),intent(inout), optional :: wv(:) end subroutine mld_d_base_smoother_apply_vect end interface diff --git a/mlprec/mld_d_jac_smoother.f90 b/mlprec/mld_d_jac_smoother.f90 index ef03d431..be03b750 100644 --- a/mlprec/mld_d_jac_smoother.f90 +++ b/mlprec/mld_d_jac_smoother.f90 @@ -85,7 +85,7 @@ module mld_d_jac_smoother interface subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu,wv) + & sweeps,work,wv,info,init,initu) import :: psb_desc_type, mld_d_jac_smoother_type, psb_d_vect_type, psb_dpk_, & & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,& & psb_ipk_ @@ -98,10 +98,10 @@ module mld_d_jac_smoother character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu - type(psb_d_vect_type),intent(inout), optional :: wv(:) end subroutine mld_d_jac_smoother_apply_vect end interface diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index ce9d0157..636d566c 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -583,10 +583,9 @@ contains integer(psb_ipk_), intent(out) :: info class(psb_d_base_vect_type), intent(in), optional :: vmold ! - integer(psb_ipk_) :: nwv + integer(psb_ipk_) :: nwv, i info = psb_success_ nwv = lv%get_wrksz() - write(0,*) 'Debug allocate_wrk: ',nwv call psb_geasb(lv%wrk%vx2l,& & lv%base_desc,info,& & scratch=.true.,mold=vmold) @@ -599,7 +598,12 @@ contains call psb_geasb(lv%wrk%vty,& & lv%base_desc,info,& & scratch=.true.,mold=vmold) - + allocate(lv%wrk%wv(nwv),stat=info) + do i=1,nwv + call psb_geasb(lv%wrk%wv(i),& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + end do end subroutine d_base_onelev_allocate_wrk @@ -609,12 +613,17 @@ contains class(mld_d_onelev_type), target, intent(inout) :: lv integer(psb_ipk_), intent(out) :: info ! - integer(psb_ipk_) :: nwv + integer(psb_ipk_) :: nwv,i info = psb_success_ call lv%wrk%vx2l%free(info) call lv%wrk%vy2l%free(info) call lv%wrk%vtx%free(info) call lv%wrk%vty%free(info) + nwv = size(lv%wrk%wv) + do i=1,nwv + call lv%wrk%wv(i)%free(info) + end do + end subroutine d_base_onelev_free_wrk end module mld_d_onelev_mod diff --git a/mlprec/mld_s_as_smoother.f90 b/mlprec/mld_s_as_smoother.f90 index e800c279..eab3f721 100644 --- a/mlprec/mld_s_as_smoother.f90 +++ b/mlprec/mld_s_as_smoother.f90 @@ -181,7 +181,7 @@ module mld_s_as_smoother interface subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu,wv) + & trans,sweeps,work,wv,info,init,initu) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_spk_, mld_s_as_smoother_type, psb_long_int_k_, & & psb_desc_type, psb_ipk_ @@ -194,10 +194,10 @@ module mld_s_as_smoother character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu - type(psb_s_vect_type),intent(inout), optional :: wv(:) end subroutine mld_s_as_smoother_apply_vect end interface diff --git a/mlprec/mld_s_base_smoother_mod.f90 b/mlprec/mld_s_base_smoother_mod.f90 index b5cb6020..dcf3188a 100644 --- a/mlprec/mld_s_base_smoother_mod.f90 +++ b/mlprec/mld_s_base_smoother_mod.f90 @@ -158,7 +158,7 @@ module mld_s_base_smoother_mod interface subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu,wv) + & trans,sweeps,work,wv,info,init,initu) import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & & mld_s_base_smoother_type, psb_ipk_ @@ -170,10 +170,10 @@ module mld_s_base_smoother_mod character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu - type(psb_s_vect_type),intent(inout), optional :: wv(:) end subroutine mld_s_base_smoother_apply_vect end interface diff --git a/mlprec/mld_s_jac_smoother.f90 b/mlprec/mld_s_jac_smoother.f90 index ccb7d896..b13f9cbe 100644 --- a/mlprec/mld_s_jac_smoother.f90 +++ b/mlprec/mld_s_jac_smoother.f90 @@ -85,7 +85,7 @@ module mld_s_jac_smoother interface subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu,wv) + & sweeps,work,wv,info,init,initu) import :: psb_desc_type, mld_s_jac_smoother_type, psb_s_vect_type, psb_spk_, & & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,& & psb_ipk_ @@ -98,10 +98,10 @@ module mld_s_jac_smoother character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu - type(psb_s_vect_type),intent(inout), optional :: wv(:) end subroutine mld_s_jac_smoother_apply_vect end interface diff --git a/mlprec/mld_s_onelev_mod.f90 b/mlprec/mld_s_onelev_mod.f90 index 88f6bf14..94071867 100644 --- a/mlprec/mld_s_onelev_mod.f90 +++ b/mlprec/mld_s_onelev_mod.f90 @@ -583,10 +583,9 @@ contains integer(psb_ipk_), intent(out) :: info class(psb_s_base_vect_type), intent(in), optional :: vmold ! - integer(psb_ipk_) :: nwv + integer(psb_ipk_) :: nwv, i info = psb_success_ nwv = lv%get_wrksz() - write(0,*) 'Debug allocate_wrk: ',nwv call psb_geasb(lv%wrk%vx2l,& & lv%base_desc,info,& & scratch=.true.,mold=vmold) @@ -599,7 +598,12 @@ contains call psb_geasb(lv%wrk%vty,& & lv%base_desc,info,& & scratch=.true.,mold=vmold) - + allocate(lv%wrk%wv(nwv),stat=info) + do i=1,nwv + call psb_geasb(lv%wrk%wv(i),& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + end do end subroutine s_base_onelev_allocate_wrk @@ -609,12 +613,17 @@ contains class(mld_s_onelev_type), target, intent(inout) :: lv integer(psb_ipk_), intent(out) :: info ! - integer(psb_ipk_) :: nwv + integer(psb_ipk_) :: nwv,i info = psb_success_ call lv%wrk%vx2l%free(info) call lv%wrk%vy2l%free(info) call lv%wrk%vtx%free(info) call lv%wrk%vty%free(info) + nwv = size(lv%wrk%wv) + do i=1,nwv + call lv%wrk%wv(i)%free(info) + end do + end subroutine s_base_onelev_free_wrk end module mld_s_onelev_mod diff --git a/mlprec/mld_z_as_smoother.f90 b/mlprec/mld_z_as_smoother.f90 index 468026c3..9254ba17 100644 --- a/mlprec/mld_z_as_smoother.f90 +++ b/mlprec/mld_z_as_smoother.f90 @@ -181,7 +181,7 @@ module mld_z_as_smoother interface subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu,wv) + & trans,sweeps,work,wv,info,init,initu) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_dpk_, mld_z_as_smoother_type, psb_long_int_k_, & & psb_desc_type, psb_ipk_ @@ -194,10 +194,10 @@ module mld_z_as_smoother character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu - type(psb_z_vect_type),intent(inout), optional :: wv(:) end subroutine mld_z_as_smoother_apply_vect end interface diff --git a/mlprec/mld_z_base_smoother_mod.f90 b/mlprec/mld_z_base_smoother_mod.f90 index 9b607ecf..505b4926 100644 --- a/mlprec/mld_z_base_smoother_mod.f90 +++ b/mlprec/mld_z_base_smoother_mod.f90 @@ -158,7 +158,7 @@ module mld_z_base_smoother_mod interface subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info,init,initu,wv) + & trans,sweeps,work,wv,info,init,initu) import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & & mld_z_base_smoother_type, psb_ipk_ @@ -170,10 +170,10 @@ module mld_z_base_smoother_mod character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu - type(psb_z_vect_type),intent(inout), optional :: wv(:) end subroutine mld_z_base_smoother_apply_vect end interface diff --git a/mlprec/mld_z_jac_smoother.f90 b/mlprec/mld_z_jac_smoother.f90 index 08cf38f3..07b30681 100644 --- a/mlprec/mld_z_jac_smoother.f90 +++ b/mlprec/mld_z_jac_smoother.f90 @@ -85,7 +85,7 @@ module mld_z_jac_smoother interface subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info,init,initu,wv) + & sweeps,work,wv,info,init,initu) import :: psb_desc_type, mld_z_jac_smoother_type, psb_z_vect_type, psb_dpk_, & & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,& & psb_ipk_ @@ -98,10 +98,10 @@ module mld_z_jac_smoother character(len=1),intent(in) :: trans integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu - type(psb_z_vect_type),intent(inout), optional :: wv(:) end subroutine mld_z_jac_smoother_apply_vect end interface diff --git a/mlprec/mld_z_onelev_mod.f90 b/mlprec/mld_z_onelev_mod.f90 index 94a8fe43..4476e616 100644 --- a/mlprec/mld_z_onelev_mod.f90 +++ b/mlprec/mld_z_onelev_mod.f90 @@ -583,10 +583,9 @@ contains integer(psb_ipk_), intent(out) :: info class(psb_z_base_vect_type), intent(in), optional :: vmold ! - integer(psb_ipk_) :: nwv + integer(psb_ipk_) :: nwv, i info = psb_success_ nwv = lv%get_wrksz() - write(0,*) 'Debug allocate_wrk: ',nwv call psb_geasb(lv%wrk%vx2l,& & lv%base_desc,info,& & scratch=.true.,mold=vmold) @@ -599,7 +598,12 @@ contains call psb_geasb(lv%wrk%vty,& & lv%base_desc,info,& & scratch=.true.,mold=vmold) - + allocate(lv%wrk%wv(nwv),stat=info) + do i=1,nwv + call psb_geasb(lv%wrk%wv(i),& + & lv%base_desc,info,& + & scratch=.true.,mold=vmold) + end do end subroutine z_base_onelev_allocate_wrk @@ -609,12 +613,17 @@ contains class(mld_z_onelev_type), target, intent(inout) :: lv integer(psb_ipk_), intent(out) :: info ! - integer(psb_ipk_) :: nwv + integer(psb_ipk_) :: nwv,i info = psb_success_ call lv%wrk%vx2l%free(info) call lv%wrk%vy2l%free(info) call lv%wrk%vtx%free(info) call lv%wrk%vty%free(info) + nwv = size(lv%wrk%wv) + do i=1,nwv + call lv%wrk%wv(i)%free(info) + end do + end subroutine z_base_onelev_free_wrk end module mld_z_onelev_mod From 554f21992fc3452d21ed50f53285e2ec288c0b24 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 11 Dec 2017 15:16:03 +0000 Subject: [PATCH 09/16] New WRK methods in onelev data structure. --- mlprec/mld_c_onelev_mod.f90 | 153 +++++++++++++++++++++++++++++------- mlprec/mld_c_prec_type.f90 | 52 ++++++------ mlprec/mld_d_onelev_mod.f90 | 153 +++++++++++++++++++++++++++++------- mlprec/mld_d_prec_type.f90 | 52 ++++++------ mlprec/mld_s_onelev_mod.f90 | 153 +++++++++++++++++++++++++++++------- mlprec/mld_s_prec_type.f90 | 52 ++++++------ mlprec/mld_z_onelev_mod.f90 | 153 +++++++++++++++++++++++++++++------- mlprec/mld_z_prec_type.f90 | 52 ++++++------ 8 files changed, 608 insertions(+), 212 deletions(-) diff --git a/mlprec/mld_c_onelev_mod.f90 b/mlprec/mld_c_onelev_mod.f90 index b4a69b53..17c7cb1c 100644 --- a/mlprec/mld_c_onelev_mod.f90 +++ b/mlprec/mld_c_onelev_mod.f90 @@ -125,12 +125,17 @@ module mld_c_onelev_mod type(psb_c_vect_type) :: vtx, vty, vx2l, vy2l integer(psb_ipk_) :: wvsz = 0 type(psb_c_vect_type), allocatable :: wv(:) + contains + procedure, pass(wk) :: alloc => c_wrk_alloc + procedure, pass(wk) :: free => c_wrk_free + procedure, pass(wk) :: clone => c_wrk_clone + procedure, pass(wk) :: move_alloc => c_wrk_move_alloc end type mld_cmlprec_wrk_type type mld_c_onelev_type class(mld_c_base_smoother_type), allocatable :: sm, sm2a class(mld_c_base_smoother_type), pointer :: sm2 => null() - type(mld_cmlprec_wrk_type) :: wrk + class(mld_cmlprec_wrk_type), allocatable :: wrk type(mld_sml_parms) :: parms type(psb_cspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -177,7 +182,8 @@ module mld_c_onelev_mod private :: c_base_onelev_default, c_base_onelev_sizeof, & & c_base_onelev_nullify, c_base_onelev_get_nzeros, & & c_base_onelev_clone, c_base_onelev_move_alloc, & - & c_base_onelev_get_wrksize, c_base_onelev_allocate_wrk, c_base_onelev_free_wrk + & c_base_onelev_get_wrksize, c_base_onelev_allocate_wrk, & + & c_base_onelev_free_wrk @@ -586,24 +592,9 @@ contains integer(psb_ipk_) :: nwv, i info = psb_success_ nwv = lv%get_wrksz() - call psb_geasb(lv%wrk%vx2l,& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(lv%wrk%vy2l,& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(lv%wrk%vtx,& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(lv%wrk%vty,& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - allocate(lv%wrk%wv(nwv),stat=info) - do i=1,nwv - call psb_geasb(lv%wrk%wv(i),& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - end do + if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info) + if (info == 0) call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold) + end subroutine c_base_onelev_allocate_wrk @@ -615,15 +606,123 @@ contains ! integer(psb_ipk_) :: nwv,i info = psb_success_ - call lv%wrk%vx2l%free(info) - call lv%wrk%vy2l%free(info) - call lv%wrk%vtx%free(info) - call lv%wrk%vty%free(info) - nwv = size(lv%wrk%wv) + + call lv%wrk%free(info) + if (info == 0) deallocate(lv%wrk,stat=info) + end subroutine c_base_onelev_free_wrk + + subroutine c_wrk_alloc(wk,nwv,desc,info,vmold) + use psb_base_mod + + Implicit None + + ! Arguments + class(mld_cmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_vect_type), intent(in), optional :: vmold + ! + integer(psb_ipk_) :: i + + info = psb_success_ + call wk%free(info) + call psb_geasb(wk%vx2l,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vy2l,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vtx,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vty,desc,info,& + & scratch=.true.,mold=vmold) + allocate(wk%wv(nwv),stat=info) do i=1,nwv - call lv%wrk%wv(i)%free(info) + call psb_geasb(wk%wv(i),desc,info,& + & scratch=.true.,mold=vmold) + end do + + end subroutine c_wrk_alloc + + subroutine c_wrk_free(wk,info) + + Implicit None + + ! Arguments + class(mld_cmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + info = psb_success_ + + if (allocated(wk%tx)) deallocate(wk%tx, stat=info) + if (allocated(wk%ty)) deallocate(wk%ty, stat=info) + if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info) + if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info) + call wk%vtx%free(info) + call wk%vty%free(info) + call wk%vx2l%free(info) + call wk%vy2l%free(info) + if (allocated(wk%wv)) then + do i=1,size(wk%wv) + call wk%wv(i)%free(info) + end do + deallocate(wk%wv, stat=info) + end if + + end subroutine c_wrk_free + + subroutine c_wrk_clone(wk,wkout,info) + use psb_base_mod + Implicit None + + ! Arguments + class(mld_cmlprec_wrk_type), target, intent(inout) :: wk + class(mld_cmlprec_wrk_type), target, intent(inout) :: wkout + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + info = psb_success_ + + call psb_safe_ab_cpy(wk%tx,wkout%tx,info) + call psb_safe_ab_cpy(wk%ty,wkout%ty,info) + call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info) + call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info) + call wk%vtx%clone(wkout%vtx,info) + call wk%vty%clone(wkout%vty,info) + call wk%vx2l%clone(wkout%vx2l,info) + call wk%vy2l%clone(wkout%vy2l,info) + if (allocated(wkout%wv)) then + do i=1,size(wkout%wv) + call wkout%wv(i)%free(info) + end do + deallocate( wkout%wv) + end if + allocate(wkout%wv(size(wk%wv)),stat=info) + do i=1,size(wk%wv) + call wk%wv(i)%clone(wkout%wv(i),info) end do + return - end subroutine c_base_onelev_free_wrk + end subroutine c_wrk_clone + + subroutine c_wrk_move_alloc(wk, b,info) + implicit none + class(mld_cmlprec_wrk_type), target, intent(inout) :: wk, b + integer(psb_ipk_), intent(out) :: info + call b%free(info) + call move_alloc(wk%tx,b%tx) + call move_alloc(wk%ty,b%ty) + call move_alloc(wk%x2l,b%x2l) + call move_alloc(wk%y2l,b%y2l) + ! + ! Should define V%move_alloc.... + call move_alloc(wk%vtx%v,b%vtx%v) + call move_alloc(wk%vty%v,b%vty%v) + call move_alloc(wk%vx2l%v,b%vx2l%v) + call move_alloc(wk%vy2l%v,b%vy2l%v) + call move_alloc(wk%wv,b%wv) + + end subroutine c_wrk_move_alloc + end module mld_c_onelev_mod diff --git a/mlprec/mld_c_prec_type.f90 b/mlprec/mld_c_prec_type.f90 index 2ebdbc1c..1873d6ac 100644 --- a/mlprec/mld_c_prec_type.f90 +++ b/mlprec/mld_c_prec_type.f90 @@ -852,24 +852,24 @@ contains 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 +!!$ 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_ @@ -912,14 +912,14 @@ contains 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 +!!$ 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_ diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index 636d566c..39d76100 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -125,12 +125,17 @@ module mld_d_onelev_mod type(psb_d_vect_type) :: vtx, vty, vx2l, vy2l integer(psb_ipk_) :: wvsz = 0 type(psb_d_vect_type), allocatable :: wv(:) + contains + procedure, pass(wk) :: alloc => d_wrk_alloc + procedure, pass(wk) :: free => d_wrk_free + procedure, pass(wk) :: clone => d_wrk_clone + procedure, pass(wk) :: move_alloc => d_wrk_move_alloc end type mld_dmlprec_wrk_type type mld_d_onelev_type class(mld_d_base_smoother_type), allocatable :: sm, sm2a class(mld_d_base_smoother_type), pointer :: sm2 => null() - type(mld_dmlprec_wrk_type) :: wrk + class(mld_dmlprec_wrk_type), allocatable :: wrk type(mld_dml_parms) :: parms type(psb_dspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -177,7 +182,8 @@ module mld_d_onelev_mod private :: d_base_onelev_default, d_base_onelev_sizeof, & & d_base_onelev_nullify, d_base_onelev_get_nzeros, & & d_base_onelev_clone, d_base_onelev_move_alloc, & - & d_base_onelev_get_wrksize, d_base_onelev_allocate_wrk, d_base_onelev_free_wrk + & d_base_onelev_get_wrksize, d_base_onelev_allocate_wrk, & + & d_base_onelev_free_wrk @@ -586,24 +592,9 @@ contains integer(psb_ipk_) :: nwv, i info = psb_success_ nwv = lv%get_wrksz() - call psb_geasb(lv%wrk%vx2l,& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(lv%wrk%vy2l,& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(lv%wrk%vtx,& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(lv%wrk%vty,& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - allocate(lv%wrk%wv(nwv),stat=info) - do i=1,nwv - call psb_geasb(lv%wrk%wv(i),& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - end do + if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info) + if (info == 0) call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold) + end subroutine d_base_onelev_allocate_wrk @@ -615,15 +606,123 @@ contains ! integer(psb_ipk_) :: nwv,i info = psb_success_ - call lv%wrk%vx2l%free(info) - call lv%wrk%vy2l%free(info) - call lv%wrk%vtx%free(info) - call lv%wrk%vty%free(info) - nwv = size(lv%wrk%wv) + + call lv%wrk%free(info) + if (info == 0) deallocate(lv%wrk,stat=info) + end subroutine d_base_onelev_free_wrk + + subroutine d_wrk_alloc(wk,nwv,desc,info,vmold) + use psb_base_mod + + Implicit None + + ! Arguments + class(mld_dmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_vect_type), intent(in), optional :: vmold + ! + integer(psb_ipk_) :: i + + info = psb_success_ + call wk%free(info) + call psb_geasb(wk%vx2l,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vy2l,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vtx,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vty,desc,info,& + & scratch=.true.,mold=vmold) + allocate(wk%wv(nwv),stat=info) do i=1,nwv - call lv%wrk%wv(i)%free(info) + call psb_geasb(wk%wv(i),desc,info,& + & scratch=.true.,mold=vmold) + end do + + end subroutine d_wrk_alloc + + subroutine d_wrk_free(wk,info) + + Implicit None + + ! Arguments + class(mld_dmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + info = psb_success_ + + if (allocated(wk%tx)) deallocate(wk%tx, stat=info) + if (allocated(wk%ty)) deallocate(wk%ty, stat=info) + if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info) + if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info) + call wk%vtx%free(info) + call wk%vty%free(info) + call wk%vx2l%free(info) + call wk%vy2l%free(info) + if (allocated(wk%wv)) then + do i=1,size(wk%wv) + call wk%wv(i)%free(info) + end do + deallocate(wk%wv, stat=info) + end if + + end subroutine d_wrk_free + + subroutine d_wrk_clone(wk,wkout,info) + use psb_base_mod + Implicit None + + ! Arguments + class(mld_dmlprec_wrk_type), target, intent(inout) :: wk + class(mld_dmlprec_wrk_type), target, intent(inout) :: wkout + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + info = psb_success_ + + call psb_safe_ab_cpy(wk%tx,wkout%tx,info) + call psb_safe_ab_cpy(wk%ty,wkout%ty,info) + call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info) + call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info) + call wk%vtx%clone(wkout%vtx,info) + call wk%vty%clone(wkout%vty,info) + call wk%vx2l%clone(wkout%vx2l,info) + call wk%vy2l%clone(wkout%vy2l,info) + if (allocated(wkout%wv)) then + do i=1,size(wkout%wv) + call wkout%wv(i)%free(info) + end do + deallocate( wkout%wv) + end if + allocate(wkout%wv(size(wk%wv)),stat=info) + do i=1,size(wk%wv) + call wk%wv(i)%clone(wkout%wv(i),info) end do + return - end subroutine d_base_onelev_free_wrk + end subroutine d_wrk_clone + + subroutine d_wrk_move_alloc(wk, b,info) + implicit none + class(mld_dmlprec_wrk_type), target, intent(inout) :: wk, b + integer(psb_ipk_), intent(out) :: info + call b%free(info) + call move_alloc(wk%tx,b%tx) + call move_alloc(wk%ty,b%ty) + call move_alloc(wk%x2l,b%x2l) + call move_alloc(wk%y2l,b%y2l) + ! + ! Should define V%move_alloc.... + call move_alloc(wk%vtx%v,b%vtx%v) + call move_alloc(wk%vty%v,b%vty%v) + call move_alloc(wk%vx2l%v,b%vx2l%v) + call move_alloc(wk%vy2l%v,b%vy2l%v) + call move_alloc(wk%wv,b%wv) + + end subroutine d_wrk_move_alloc + end module mld_d_onelev_mod diff --git a/mlprec/mld_d_prec_type.f90 b/mlprec/mld_d_prec_type.f90 index aaefadfc..551cedab 100644 --- a/mlprec/mld_d_prec_type.f90 +++ b/mlprec/mld_d_prec_type.f90 @@ -852,24 +852,24 @@ contains 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 +!!$ 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_ @@ -912,14 +912,14 @@ contains 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 +!!$ 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_ diff --git a/mlprec/mld_s_onelev_mod.f90 b/mlprec/mld_s_onelev_mod.f90 index 94071867..39a98aa9 100644 --- a/mlprec/mld_s_onelev_mod.f90 +++ b/mlprec/mld_s_onelev_mod.f90 @@ -125,12 +125,17 @@ module mld_s_onelev_mod type(psb_s_vect_type) :: vtx, vty, vx2l, vy2l integer(psb_ipk_) :: wvsz = 0 type(psb_s_vect_type), allocatable :: wv(:) + contains + procedure, pass(wk) :: alloc => s_wrk_alloc + procedure, pass(wk) :: free => s_wrk_free + procedure, pass(wk) :: clone => s_wrk_clone + procedure, pass(wk) :: move_alloc => s_wrk_move_alloc end type mld_smlprec_wrk_type type mld_s_onelev_type class(mld_s_base_smoother_type), allocatable :: sm, sm2a class(mld_s_base_smoother_type), pointer :: sm2 => null() - type(mld_smlprec_wrk_type) :: wrk + class(mld_smlprec_wrk_type), allocatable :: wrk type(mld_sml_parms) :: parms type(psb_sspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -177,7 +182,8 @@ module mld_s_onelev_mod private :: s_base_onelev_default, s_base_onelev_sizeof, & & s_base_onelev_nullify, s_base_onelev_get_nzeros, & & s_base_onelev_clone, s_base_onelev_move_alloc, & - & s_base_onelev_get_wrksize, s_base_onelev_allocate_wrk, s_base_onelev_free_wrk + & s_base_onelev_get_wrksize, s_base_onelev_allocate_wrk, & + & s_base_onelev_free_wrk @@ -586,24 +592,9 @@ contains integer(psb_ipk_) :: nwv, i info = psb_success_ nwv = lv%get_wrksz() - call psb_geasb(lv%wrk%vx2l,& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(lv%wrk%vy2l,& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(lv%wrk%vtx,& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(lv%wrk%vty,& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - allocate(lv%wrk%wv(nwv),stat=info) - do i=1,nwv - call psb_geasb(lv%wrk%wv(i),& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - end do + if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info) + if (info == 0) call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold) + end subroutine s_base_onelev_allocate_wrk @@ -615,15 +606,123 @@ contains ! integer(psb_ipk_) :: nwv,i info = psb_success_ - call lv%wrk%vx2l%free(info) - call lv%wrk%vy2l%free(info) - call lv%wrk%vtx%free(info) - call lv%wrk%vty%free(info) - nwv = size(lv%wrk%wv) + + call lv%wrk%free(info) + if (info == 0) deallocate(lv%wrk,stat=info) + end subroutine s_base_onelev_free_wrk + + subroutine s_wrk_alloc(wk,nwv,desc,info,vmold) + use psb_base_mod + + Implicit None + + ! Arguments + class(mld_smlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_vect_type), intent(in), optional :: vmold + ! + integer(psb_ipk_) :: i + + info = psb_success_ + call wk%free(info) + call psb_geasb(wk%vx2l,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vy2l,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vtx,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vty,desc,info,& + & scratch=.true.,mold=vmold) + allocate(wk%wv(nwv),stat=info) do i=1,nwv - call lv%wrk%wv(i)%free(info) + call psb_geasb(wk%wv(i),desc,info,& + & scratch=.true.,mold=vmold) + end do + + end subroutine s_wrk_alloc + + subroutine s_wrk_free(wk,info) + + Implicit None + + ! Arguments + class(mld_smlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + info = psb_success_ + + if (allocated(wk%tx)) deallocate(wk%tx, stat=info) + if (allocated(wk%ty)) deallocate(wk%ty, stat=info) + if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info) + if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info) + call wk%vtx%free(info) + call wk%vty%free(info) + call wk%vx2l%free(info) + call wk%vy2l%free(info) + if (allocated(wk%wv)) then + do i=1,size(wk%wv) + call wk%wv(i)%free(info) + end do + deallocate(wk%wv, stat=info) + end if + + end subroutine s_wrk_free + + subroutine s_wrk_clone(wk,wkout,info) + use psb_base_mod + Implicit None + + ! Arguments + class(mld_smlprec_wrk_type), target, intent(inout) :: wk + class(mld_smlprec_wrk_type), target, intent(inout) :: wkout + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + info = psb_success_ + + call psb_safe_ab_cpy(wk%tx,wkout%tx,info) + call psb_safe_ab_cpy(wk%ty,wkout%ty,info) + call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info) + call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info) + call wk%vtx%clone(wkout%vtx,info) + call wk%vty%clone(wkout%vty,info) + call wk%vx2l%clone(wkout%vx2l,info) + call wk%vy2l%clone(wkout%vy2l,info) + if (allocated(wkout%wv)) then + do i=1,size(wkout%wv) + call wkout%wv(i)%free(info) + end do + deallocate( wkout%wv) + end if + allocate(wkout%wv(size(wk%wv)),stat=info) + do i=1,size(wk%wv) + call wk%wv(i)%clone(wkout%wv(i),info) end do + return - end subroutine s_base_onelev_free_wrk + end subroutine s_wrk_clone + + subroutine s_wrk_move_alloc(wk, b,info) + implicit none + class(mld_smlprec_wrk_type), target, intent(inout) :: wk, b + integer(psb_ipk_), intent(out) :: info + call b%free(info) + call move_alloc(wk%tx,b%tx) + call move_alloc(wk%ty,b%ty) + call move_alloc(wk%x2l,b%x2l) + call move_alloc(wk%y2l,b%y2l) + ! + ! Should define V%move_alloc.... + call move_alloc(wk%vtx%v,b%vtx%v) + call move_alloc(wk%vty%v,b%vty%v) + call move_alloc(wk%vx2l%v,b%vx2l%v) + call move_alloc(wk%vy2l%v,b%vy2l%v) + call move_alloc(wk%wv,b%wv) + + end subroutine s_wrk_move_alloc + end module mld_s_onelev_mod diff --git a/mlprec/mld_s_prec_type.f90 b/mlprec/mld_s_prec_type.f90 index 9b1efb2e..579b0e0b 100644 --- a/mlprec/mld_s_prec_type.f90 +++ b/mlprec/mld_s_prec_type.f90 @@ -852,24 +852,24 @@ contains 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 +!!$ 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_ @@ -912,14 +912,14 @@ contains 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 +!!$ 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_ diff --git a/mlprec/mld_z_onelev_mod.f90 b/mlprec/mld_z_onelev_mod.f90 index 4476e616..e9f7cc71 100644 --- a/mlprec/mld_z_onelev_mod.f90 +++ b/mlprec/mld_z_onelev_mod.f90 @@ -125,12 +125,17 @@ module mld_z_onelev_mod type(psb_z_vect_type) :: vtx, vty, vx2l, vy2l integer(psb_ipk_) :: wvsz = 0 type(psb_z_vect_type), allocatable :: wv(:) + contains + procedure, pass(wk) :: alloc => z_wrk_alloc + procedure, pass(wk) :: free => z_wrk_free + procedure, pass(wk) :: clone => z_wrk_clone + procedure, pass(wk) :: move_alloc => z_wrk_move_alloc end type mld_zmlprec_wrk_type type mld_z_onelev_type class(mld_z_base_smoother_type), allocatable :: sm, sm2a class(mld_z_base_smoother_type), pointer :: sm2 => null() - type(mld_zmlprec_wrk_type) :: wrk + class(mld_zmlprec_wrk_type), allocatable :: wrk type(mld_dml_parms) :: parms type(psb_zspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -177,7 +182,8 @@ module mld_z_onelev_mod private :: z_base_onelev_default, z_base_onelev_sizeof, & & z_base_onelev_nullify, z_base_onelev_get_nzeros, & & z_base_onelev_clone, z_base_onelev_move_alloc, & - & z_base_onelev_get_wrksize, z_base_onelev_allocate_wrk, z_base_onelev_free_wrk + & z_base_onelev_get_wrksize, z_base_onelev_allocate_wrk, & + & z_base_onelev_free_wrk @@ -586,24 +592,9 @@ contains integer(psb_ipk_) :: nwv, i info = psb_success_ nwv = lv%get_wrksz() - call psb_geasb(lv%wrk%vx2l,& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(lv%wrk%vy2l,& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(lv%wrk%vtx,& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - call psb_geasb(lv%wrk%vty,& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - allocate(lv%wrk%wv(nwv),stat=info) - do i=1,nwv - call psb_geasb(lv%wrk%wv(i),& - & lv%base_desc,info,& - & scratch=.true.,mold=vmold) - end do + if (.not.allocated(lv%wrk)) allocate(lv%wrk,stat=info) + if (info == 0) call lv%wrk%alloc(nwv,lv%base_desc,info,vmold=vmold) + end subroutine z_base_onelev_allocate_wrk @@ -615,15 +606,123 @@ contains ! integer(psb_ipk_) :: nwv,i info = psb_success_ - call lv%wrk%vx2l%free(info) - call lv%wrk%vy2l%free(info) - call lv%wrk%vtx%free(info) - call lv%wrk%vty%free(info) - nwv = size(lv%wrk%wv) + + call lv%wrk%free(info) + if (info == 0) deallocate(lv%wrk,stat=info) + end subroutine z_base_onelev_free_wrk + + subroutine z_wrk_alloc(wk,nwv,desc,info,vmold) + use psb_base_mod + + Implicit None + + ! Arguments + class(mld_zmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(in) :: nwv + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_vect_type), intent(in), optional :: vmold + ! + integer(psb_ipk_) :: i + + info = psb_success_ + call wk%free(info) + call psb_geasb(wk%vx2l,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vy2l,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vtx,desc,info,& + & scratch=.true.,mold=vmold) + call psb_geasb(wk%vty,desc,info,& + & scratch=.true.,mold=vmold) + allocate(wk%wv(nwv),stat=info) do i=1,nwv - call lv%wrk%wv(i)%free(info) + call psb_geasb(wk%wv(i),desc,info,& + & scratch=.true.,mold=vmold) + end do + + end subroutine z_wrk_alloc + + subroutine z_wrk_free(wk,info) + + Implicit None + + ! Arguments + class(mld_zmlprec_wrk_type), target, intent(inout) :: wk + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + info = psb_success_ + + if (allocated(wk%tx)) deallocate(wk%tx, stat=info) + if (allocated(wk%ty)) deallocate(wk%ty, stat=info) + if (allocated(wk%x2l)) deallocate(wk%x2l, stat=info) + if (allocated(wk%y2l)) deallocate(wk%y2l, stat=info) + call wk%vtx%free(info) + call wk%vty%free(info) + call wk%vx2l%free(info) + call wk%vy2l%free(info) + if (allocated(wk%wv)) then + do i=1,size(wk%wv) + call wk%wv(i)%free(info) + end do + deallocate(wk%wv, stat=info) + end if + + end subroutine z_wrk_free + + subroutine z_wrk_clone(wk,wkout,info) + use psb_base_mod + Implicit None + + ! Arguments + class(mld_zmlprec_wrk_type), target, intent(inout) :: wk + class(mld_zmlprec_wrk_type), target, intent(inout) :: wkout + integer(psb_ipk_), intent(out) :: info + ! + integer(psb_ipk_) :: i + info = psb_success_ + + call psb_safe_ab_cpy(wk%tx,wkout%tx,info) + call psb_safe_ab_cpy(wk%ty,wkout%ty,info) + call psb_safe_ab_cpy(wk%x2l,wkout%x2l,info) + call psb_safe_ab_cpy(wk%y2l,wkout%y2l,info) + call wk%vtx%clone(wkout%vtx,info) + call wk%vty%clone(wkout%vty,info) + call wk%vx2l%clone(wkout%vx2l,info) + call wk%vy2l%clone(wkout%vy2l,info) + if (allocated(wkout%wv)) then + do i=1,size(wkout%wv) + call wkout%wv(i)%free(info) + end do + deallocate( wkout%wv) + end if + allocate(wkout%wv(size(wk%wv)),stat=info) + do i=1,size(wk%wv) + call wk%wv(i)%clone(wkout%wv(i),info) end do + return - end subroutine z_base_onelev_free_wrk + end subroutine z_wrk_clone + + subroutine z_wrk_move_alloc(wk, b,info) + implicit none + class(mld_zmlprec_wrk_type), target, intent(inout) :: wk, b + integer(psb_ipk_), intent(out) :: info + call b%free(info) + call move_alloc(wk%tx,b%tx) + call move_alloc(wk%ty,b%ty) + call move_alloc(wk%x2l,b%x2l) + call move_alloc(wk%y2l,b%y2l) + ! + ! Should define V%move_alloc.... + call move_alloc(wk%vtx%v,b%vtx%v) + call move_alloc(wk%vty%v,b%vty%v) + call move_alloc(wk%vx2l%v,b%vx2l%v) + call move_alloc(wk%vy2l%v,b%vy2l%v) + call move_alloc(wk%wv,b%wv) + + end subroutine z_wrk_move_alloc + end module mld_z_onelev_mod diff --git a/mlprec/mld_z_prec_type.f90 b/mlprec/mld_z_prec_type.f90 index d5662f15..0c261a0a 100644 --- a/mlprec/mld_z_prec_type.f90 +++ b/mlprec/mld_z_prec_type.f90 @@ -852,24 +852,24 @@ contains 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 +!!$ 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_ @@ -912,14 +912,14 @@ contains 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 +!!$ 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_ From 3250853810793da7f428d95e093949a317c12159 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 11 Dec 2017 16:47:21 +0000 Subject: [PATCH 10/16] Taken out WRK(:) component of PREC, now we have the WRK component of LEV. --- mlprec/impl/mld_cmlprec_aply.f90 | 2 +- mlprec/impl/mld_cprecaply.f90 | 8 ++-- mlprec/impl/mld_dmlprec_aply.f90 | 2 +- mlprec/impl/mld_dprecaply.f90 | 8 ++-- mlprec/impl/mld_smlprec_aply.f90 | 2 +- mlprec/impl/mld_sprecaply.f90 | 8 ++-- mlprec/impl/mld_zmlprec_aply.f90 | 2 +- mlprec/impl/mld_zprecaply.f90 | 8 ++-- mlprec/mld_c_onelev_mod.f90 | 10 +++-- mlprec/mld_c_prec_type.f90 | 65 +++----------------------------- mlprec/mld_d_onelev_mod.f90 | 10 +++-- mlprec/mld_d_prec_type.f90 | 65 +++----------------------------- mlprec/mld_s_onelev_mod.f90 | 10 +++-- mlprec/mld_s_prec_type.f90 | 65 +++----------------------------- mlprec/mld_z_onelev_mod.f90 | 10 +++-- mlprec/mld_z_prec_type.f90 | 65 +++----------------------------- 16 files changed, 72 insertions(+), 268 deletions(-) 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 From 4564e1e4bacca029fccdf36f5869e5d4047fc466 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 11 Dec 2017 17:17:43 +0000 Subject: [PATCH 11/16] Cleanup smoother_apply. --- .../impl/smoother/mld_c_as_smoother_apply_vect.f90 | 7 +------ .../impl/smoother/mld_c_jac_smoother_apply_vect.f90 | 12 ------------ .../impl/smoother/mld_d_as_smoother_apply_vect.f90 | 7 +------ .../impl/smoother/mld_d_jac_smoother_apply_vect.f90 | 12 ------------ .../impl/smoother/mld_s_as_smoother_apply_vect.f90 | 7 +------ .../impl/smoother/mld_s_jac_smoother_apply_vect.f90 | 12 ------------ .../impl/smoother/mld_z_as_smoother_apply_vect.f90 | 7 +------ .../impl/smoother/mld_z_jac_smoother_apply_vect.f90 | 12 ------------ 8 files changed, 4 insertions(+), 72 deletions(-) diff --git a/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 index 6fc4ae38..23bb76ab 100644 --- a/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 @@ -132,9 +132,6 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if associate(tx => wv(1), ty => wv(2), ww => wv(3)) -!!$ call psb_geasb(tx,sm%desc_data,info,mold=x%v,scratch=.true.) -!!$ call psb_geasb(ty,sm%desc_data,info,mold=x%v,scratch=.true.) -!!$ call psb_geasb(ww,sm%desc_data,info,mold=x%v,scratch=.true.) ! Need to zero tx because of the apply_restr call. call tx%zero() ! @@ -227,9 +224,7 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (.not.(4*isz <= size(work))) then deallocate(aux,stat=info) endif -!!$ if (info ==0) call ww%free(info) -!!$ if (info ==0) call tx%free(info) -!!$ if (info ==0) call ty%free(info) + if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 index 5e393745..bc316805 100644 --- a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 @@ -124,15 +124,11 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! if (size(wv) < 2) then info = psb_err_internal_error_ - write(0,*) 'Size (WV) : ',size(wv) call psb_errpush(info,name,& & a_err='invalid wv size in smoother_apply') goto 9999 end if associate(tx => wv(1), ty => wv(2)) -!!$ call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.) -!!$ call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.) - ! ! Unroll the first iteration and fold it inside SELECT CASE @@ -192,14 +188,6 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end if -!!$ call tx%free(info) -!!$ if (info == psb_success_) call ty%free(info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_internal_error_ -!!$ call psb_errpush(info,name,& -!!$ & a_err='final cleanup with Jacobi sweeps > 1') -!!$ goto 9999 -!!$ end if end associate else diff --git a/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 index 68bae713..d0c99f3f 100644 --- a/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 @@ -132,9 +132,6 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if associate(tx => wv(1), ty => wv(2), ww => wv(3)) -!!$ call psb_geasb(tx,sm%desc_data,info,mold=x%v,scratch=.true.) -!!$ call psb_geasb(ty,sm%desc_data,info,mold=x%v,scratch=.true.) -!!$ call psb_geasb(ww,sm%desc_data,info,mold=x%v,scratch=.true.) ! Need to zero tx because of the apply_restr call. call tx%zero() ! @@ -227,9 +224,7 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (.not.(4*isz <= size(work))) then deallocate(aux,stat=info) endif -!!$ if (info ==0) call ww%free(info) -!!$ if (info ==0) call tx%free(info) -!!$ if (info ==0) call ty%free(info) + if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 index c5d2b002..82ab514e 100644 --- a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 @@ -124,15 +124,11 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! if (size(wv) < 2) then info = psb_err_internal_error_ - write(0,*) 'Size (WV) : ',size(wv) call psb_errpush(info,name,& & a_err='invalid wv size in smoother_apply') goto 9999 end if associate(tx => wv(1), ty => wv(2)) -!!$ call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.) -!!$ call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.) - ! ! Unroll the first iteration and fold it inside SELECT CASE @@ -192,14 +188,6 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end if -!!$ call tx%free(info) -!!$ if (info == psb_success_) call ty%free(info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_internal_error_ -!!$ call psb_errpush(info,name,& -!!$ & a_err='final cleanup with Jacobi sweeps > 1') -!!$ goto 9999 -!!$ end if end associate else diff --git a/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 index ecfcd54b..18b53ee9 100644 --- a/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 @@ -132,9 +132,6 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if associate(tx => wv(1), ty => wv(2), ww => wv(3)) -!!$ call psb_geasb(tx,sm%desc_data,info,mold=x%v,scratch=.true.) -!!$ call psb_geasb(ty,sm%desc_data,info,mold=x%v,scratch=.true.) -!!$ call psb_geasb(ww,sm%desc_data,info,mold=x%v,scratch=.true.) ! Need to zero tx because of the apply_restr call. call tx%zero() ! @@ -227,9 +224,7 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (.not.(4*isz <= size(work))) then deallocate(aux,stat=info) endif -!!$ if (info ==0) call ww%free(info) -!!$ if (info ==0) call tx%free(info) -!!$ if (info ==0) call ty%free(info) + if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 index 64927b4e..94f5d601 100644 --- a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 @@ -124,15 +124,11 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! if (size(wv) < 2) then info = psb_err_internal_error_ - write(0,*) 'Size (WV) : ',size(wv) call psb_errpush(info,name,& & a_err='invalid wv size in smoother_apply') goto 9999 end if associate(tx => wv(1), ty => wv(2)) -!!$ call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.) -!!$ call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.) - ! ! Unroll the first iteration and fold it inside SELECT CASE @@ -192,14 +188,6 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end if -!!$ call tx%free(info) -!!$ if (info == psb_success_) call ty%free(info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_internal_error_ -!!$ call psb_errpush(info,name,& -!!$ & a_err='final cleanup with Jacobi sweeps > 1') -!!$ goto 9999 -!!$ end if end associate else diff --git a/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 index ae52866b..4ec1deb4 100644 --- a/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 @@ -132,9 +132,6 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if associate(tx => wv(1), ty => wv(2), ww => wv(3)) -!!$ call psb_geasb(tx,sm%desc_data,info,mold=x%v,scratch=.true.) -!!$ call psb_geasb(ty,sm%desc_data,info,mold=x%v,scratch=.true.) -!!$ call psb_geasb(ww,sm%desc_data,info,mold=x%v,scratch=.true.) ! Need to zero tx because of the apply_restr call. call tx%zero() ! @@ -227,9 +224,7 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (.not.(4*isz <= size(work))) then deallocate(aux,stat=info) endif -!!$ if (info ==0) call ww%free(info) -!!$ if (info ==0) call tx%free(info) -!!$ if (info ==0) call ty%free(info) + if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info,name) diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 index af0e6488..b576d0da 100644 --- a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 @@ -124,15 +124,11 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! if (size(wv) < 2) then info = psb_err_internal_error_ - write(0,*) 'Size (WV) : ',size(wv) call psb_errpush(info,name,& & a_err='invalid wv size in smoother_apply') goto 9999 end if associate(tx => wv(1), ty => wv(2)) -!!$ call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.) -!!$ call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.) - ! ! Unroll the first iteration and fold it inside SELECT CASE @@ -192,14 +188,6 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end if -!!$ call tx%free(info) -!!$ if (info == psb_success_) call ty%free(info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_internal_error_ -!!$ call psb_errpush(info,name,& -!!$ & a_err='final cleanup with Jacobi sweeps > 1') -!!$ goto 9999 -!!$ end if end associate else From 2481fec23d83bd135ff34242c3ab9d0b87583909 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 11 Dec 2017 17:45:46 +0000 Subject: [PATCH 12/16] Added WV to solver apply_vect interface. --- .../smoother/mld_c_as_smoother_apply_vect.f90 | 10 +++---- .../mld_c_base_smoother_apply_vect.f90 | 2 +- .../mld_c_jac_smoother_apply_vect.f90 | 10 +++---- .../smoother/mld_d_as_smoother_apply_vect.f90 | 10 +++---- .../mld_d_base_smoother_apply_vect.f90 | 2 +- .../mld_d_jac_smoother_apply_vect.f90 | 10 +++---- .../smoother/mld_s_as_smoother_apply_vect.f90 | 10 +++---- .../mld_s_base_smoother_apply_vect.f90 | 2 +- .../mld_s_jac_smoother_apply_vect.f90 | 10 +++---- .../smoother/mld_z_as_smoother_apply_vect.f90 | 10 +++---- .../mld_z_base_smoother_apply_vect.f90 | 2 +- .../mld_z_jac_smoother_apply_vect.f90 | 10 +++---- .../solver/mld_c_base_solver_apply_vect.f90 | 3 +- .../solver/mld_c_bwgs_solver_apply_vect.f90 | 30 +++++-------------- .../solver/mld_c_diag_solver_apply_vect.f90 | 3 +- .../solver/mld_c_gs_solver_apply_vect.f90 | 30 +++++-------------- .../solver/mld_c_id_solver_apply_vect.f90 | 3 +- .../solver/mld_c_ilu_solver_apply_vect.f90 | 27 +++++++++-------- .../solver/mld_c_mumps_solver_apply_vect.F90 | 5 ++-- .../solver/mld_d_base_solver_apply_vect.f90 | 3 +- .../solver/mld_d_bwgs_solver_apply_vect.f90 | 30 +++++-------------- .../solver/mld_d_diag_solver_apply_vect.f90 | 3 +- .../solver/mld_d_gs_solver_apply_vect.f90 | 30 +++++-------------- .../solver/mld_d_id_solver_apply_vect.f90 | 3 +- .../solver/mld_d_ilu_solver_apply_vect.f90 | 27 +++++++++-------- .../solver/mld_d_mumps_solver_apply_vect.F90 | 5 ++-- .../solver/mld_s_base_solver_apply_vect.f90 | 3 +- .../solver/mld_s_bwgs_solver_apply_vect.f90 | 30 +++++-------------- .../solver/mld_s_diag_solver_apply_vect.f90 | 3 +- .../solver/mld_s_gs_solver_apply_vect.f90 | 30 +++++-------------- .../solver/mld_s_id_solver_apply_vect.f90 | 3 +- .../solver/mld_s_ilu_solver_apply_vect.f90 | 27 +++++++++-------- .../solver/mld_s_mumps_solver_apply_vect.F90 | 5 ++-- .../solver/mld_z_base_solver_apply_vect.f90 | 3 +- .../solver/mld_z_bwgs_solver_apply_vect.f90 | 30 +++++-------------- .../solver/mld_z_diag_solver_apply_vect.f90 | 3 +- .../solver/mld_z_gs_solver_apply_vect.f90 | 30 +++++-------------- .../solver/mld_z_id_solver_apply_vect.f90 | 3 +- .../solver/mld_z_ilu_solver_apply_vect.f90 | 27 +++++++++-------- .../solver/mld_z_mumps_solver_apply_vect.F90 | 5 ++-- mlprec/mld_c_base_solver_mod.f90 | 3 +- mlprec/mld_c_diag_solver.f90 | 3 +- mlprec/mld_c_gs_solver.f90 | 6 ++-- mlprec/mld_c_id_solver.f90 | 3 +- mlprec/mld_c_ilu_solver.f90 | 3 +- mlprec/mld_c_mumps_solver.F90 | 5 ++-- mlprec/mld_c_slu_solver.F90 | 7 +++-- mlprec/mld_d_base_solver_mod.f90 | 3 +- mlprec/mld_d_diag_solver.f90 | 3 +- mlprec/mld_d_gs_solver.f90 | 6 ++-- mlprec/mld_d_id_solver.f90 | 3 +- mlprec/mld_d_ilu_solver.f90 | 3 +- mlprec/mld_d_mumps_solver.F90 | 5 ++-- mlprec/mld_d_slu_solver.F90 | 7 +++-- mlprec/mld_d_sludist_solver.F90 | 7 +++-- mlprec/mld_d_umf_solver.F90 | 5 ++-- mlprec/mld_s_base_solver_mod.f90 | 3 +- mlprec/mld_s_diag_solver.f90 | 3 +- mlprec/mld_s_gs_solver.f90 | 6 ++-- mlprec/mld_s_id_solver.f90 | 3 +- mlprec/mld_s_ilu_solver.f90 | 3 +- mlprec/mld_s_mumps_solver.F90 | 5 ++-- mlprec/mld_s_slu_solver.F90 | 7 +++-- mlprec/mld_z_base_solver_mod.f90 | 3 +- mlprec/mld_z_diag_solver.f90 | 3 +- mlprec/mld_z_gs_solver.f90 | 6 ++-- mlprec/mld_z_id_solver.f90 | 3 +- mlprec/mld_z_ilu_solver.f90 | 3 +- mlprec/mld_z_mumps_solver.F90 | 5 ++-- mlprec/mld_z_slu_solver.F90 | 7 +++-- mlprec/mld_z_sludist_solver.F90 | 7 +++-- mlprec/mld_z_umf_solver.F90 | 5 ++-- 72 files changed, 290 insertions(+), 346 deletions(-) diff --git a/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 index 23bb76ab..912dec94 100644 --- a/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 @@ -110,7 +110,7 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! ! Shortcut: in this case there is nothing else to be done. ! - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -145,14 +145,14 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& select case (init_) case('Z') - call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Z') + call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z') case('Y') call psb_geaxpby(cone,y,czero,ty,desc_data,info) if (info == 0) call sm%apply_restr(ty,trans_,aux,info) if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,& & work=aux,trans=trans_) - call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,wv(4:),info,init='Y') case('U') if (.not.present(initu)) then @@ -164,7 +164,7 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info == 0) call sm%apply_restr(ty,trans_,aux,info) if (info == 0) call psb_spmm(-cone,sm%nd,ty,cone,ww,sm%desc_data,info,& & work=aux,trans=trans_) - call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(cone,ww,czero,ty,desc_data,trans_,aux,wv(4:),info,init='Y') case default call psb_errpush(psb_err_internal_error_,name,& @@ -191,7 +191,7 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y') if (info /= psb_success_) exit if (info == 0) call sm%apply_prol(ty,trans_,aux,info) diff --git a/mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 index 9015b07c..9ac70761 100644 --- a/mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 @@ -68,7 +68,7 @@ subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& else if (allocated(sm%sv)) then - call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info,init=init, initu=initu) + call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,wv,info,init=init, initu=initu) else info = 1121 endif diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 index bc316805..fce635c5 100644 --- a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 @@ -107,7 +107,7 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nnz_nd_tot==0))) then ! if .not.sv%is_iterative, there's no need to pass init - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,& @@ -138,13 +138,13 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& select case (init_) case('Z') - call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,info,init='Z') + call sm%sv%apply(cone,x,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') case('Y') call psb_geaxpby(cone,x,czero,tx,desc_data,info) call psb_geaxpby(cone,y,czero,ty,desc_data,info) call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case('U') if (.not.present(initu)) then @@ -155,7 +155,7 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(cone,x,czero,tx,desc_data,info) call psb_geaxpby(cone,initu,czero,ty,desc_data,info) call psb_spmm(-cone,sm%nd,ty,cone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case default call psb_errpush(psb_err_internal_error_,name,& @@ -174,7 +174,7 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(cone,tx,czero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') if (info /= psb_success_) exit end do diff --git a/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 index d0c99f3f..759340ab 100644 --- a/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 @@ -110,7 +110,7 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! ! Shortcut: in this case there is nothing else to be done. ! - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -145,14 +145,14 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& select case (init_) case('Z') - call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info,init='Z') + call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z') case('Y') call psb_geaxpby(done,y,dzero,ty,desc_data,info) if (info == 0) call sm%apply_restr(ty,trans_,aux,info) if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,& & work=aux,trans=trans_) - call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,wv(4:),info,init='Y') case('U') if (.not.present(initu)) then @@ -164,7 +164,7 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info == 0) call sm%apply_restr(ty,trans_,aux,info) if (info == 0) call psb_spmm(-done,sm%nd,ty,done,ww,sm%desc_data,info,& & work=aux,trans=trans_) - call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(done,ww,dzero,ty,desc_data,trans_,aux,wv(4:),info,init='Y') case default call psb_errpush(psb_err_internal_error_,name,& @@ -191,7 +191,7 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y') if (info /= psb_success_) exit if (info == 0) call sm%apply_prol(ty,trans_,aux,info) diff --git a/mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 index f153a18a..7e0d91bf 100644 --- a/mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 @@ -68,7 +68,7 @@ subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& else if (allocated(sm%sv)) then - call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info,init=init, initu=initu) + call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,wv,info,init=init, initu=initu) else info = 1121 endif diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 index 82ab514e..349e9ad9 100644 --- a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 @@ -107,7 +107,7 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nnz_nd_tot==0))) then ! if .not.sv%is_iterative, there's no need to pass init - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,& @@ -138,13 +138,13 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& select case (init_) case('Z') - call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,info,init='Z') + call sm%sv%apply(done,x,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') case('Y') call psb_geaxpby(done,x,dzero,tx,desc_data,info) call psb_geaxpby(done,y,dzero,ty,desc_data,info) call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case('U') if (.not.present(initu)) then @@ -155,7 +155,7 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(done,x,dzero,tx,desc_data,info) call psb_geaxpby(done,initu,dzero,ty,desc_data,info) call psb_spmm(-done,sm%nd,ty,done,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case default call psb_errpush(psb_err_internal_error_,name,& @@ -174,7 +174,7 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(done,tx,dzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') if (info /= psb_success_) exit end do diff --git a/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 index 18b53ee9..85ed0099 100644 --- a/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 @@ -110,7 +110,7 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! ! Shortcut: in this case there is nothing else to be done. ! - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -145,14 +145,14 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& select case (init_) case('Z') - call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info,init='Z') + call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z') case('Y') call psb_geaxpby(sone,y,szero,ty,desc_data,info) if (info == 0) call sm%apply_restr(ty,trans_,aux,info) if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,& & work=aux,trans=trans_) - call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,wv(4:),info,init='Y') case('U') if (.not.present(initu)) then @@ -164,7 +164,7 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info == 0) call sm%apply_restr(ty,trans_,aux,info) if (info == 0) call psb_spmm(-sone,sm%nd,ty,sone,ww,sm%desc_data,info,& & work=aux,trans=trans_) - call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(sone,ww,szero,ty,desc_data,trans_,aux,wv(4:),info,init='Y') case default call psb_errpush(psb_err_internal_error_,name,& @@ -191,7 +191,7 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y') if (info /= psb_success_) exit if (info == 0) call sm%apply_prol(ty,trans_,aux,info) diff --git a/mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 index c3fb485e..a8865eb6 100644 --- a/mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 @@ -68,7 +68,7 @@ subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& else if (allocated(sm%sv)) then - call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info,init=init, initu=initu) + call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,wv,info,init=init, initu=initu) else info = 1121 endif diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 index 94f5d601..47b8ee3c 100644 --- a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 @@ -107,7 +107,7 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nnz_nd_tot==0))) then ! if .not.sv%is_iterative, there's no need to pass init - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,& @@ -138,13 +138,13 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& select case (init_) case('Z') - call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,info,init='Z') + call sm%sv%apply(sone,x,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') case('Y') call psb_geaxpby(sone,x,szero,tx,desc_data,info) call psb_geaxpby(sone,y,szero,ty,desc_data,info) call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case('U') if (.not.present(initu)) then @@ -155,7 +155,7 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(sone,x,szero,tx,desc_data,info) call psb_geaxpby(sone,initu,szero,ty,desc_data,info) call psb_spmm(-sone,sm%nd,ty,sone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case default call psb_errpush(psb_err_internal_error_,name,& @@ -174,7 +174,7 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(sone,tx,szero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') if (info /= psb_success_) exit end do diff --git a/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 index 4ec1deb4..6730d5aa 100644 --- a/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 @@ -110,7 +110,7 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! ! Shortcut: in this case there is nothing else to be done. ! - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -145,14 +145,14 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& select case (init_) case('Z') - call sm%sv%apply(zone,ww,zzero,ty,sm%desc_data,trans_,aux,info,init='Z') + call sm%sv%apply(zone,ww,zzero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Z') case('Y') call psb_geaxpby(zone,y,zzero,ty,desc_data,info) if (info == 0) call sm%apply_restr(ty,trans_,aux,info) if (info == 0) call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,& & work=aux,trans=trans_) - call sm%sv%apply(zone,ww,zzero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(zone,ww,zzero,ty,desc_data,trans_,aux,wv(4:),info,init='Y') case('U') if (.not.present(initu)) then @@ -164,7 +164,7 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info == 0) call sm%apply_restr(ty,trans_,aux,info) if (info == 0) call psb_spmm(-zone,sm%nd,ty,zone,ww,sm%desc_data,info,& & work=aux,trans=trans_) - call sm%sv%apply(zone,ww,zzero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(zone,ww,zzero,ty,desc_data,trans_,aux,wv(4:),info,init='Y') case default call psb_errpush(psb_err_internal_error_,name,& @@ -191,7 +191,7 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(zone,ww,zzero,ty,sm%desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(zone,ww,zzero,ty,sm%desc_data,trans_,aux,wv(4:),info,init='Y') if (info /= psb_success_) exit if (info == 0) call sm%apply_prol(ty,trans_,aux,info) diff --git a/mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 index 18e24b82..c8ffd133 100644 --- a/mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 @@ -68,7 +68,7 @@ subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& else if (allocated(sm%sv)) then - call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info,init=init, initu=initu) + call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,wv,info,init=init, initu=initu) else info = 1121 endif diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 index b576d0da..b72288bd 100644 --- a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 @@ -107,7 +107,7 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nnz_nd_tot==0))) then ! if .not.sv%is_iterative, there's no need to pass init - call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) + call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,wv,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,& @@ -138,13 +138,13 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& select case (init_) case('Z') - call sm%sv%apply(zone,x,zzero,ty,desc_data,trans_,aux,info,init='Z') + call sm%sv%apply(zone,x,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Z') case('Y') call psb_geaxpby(zone,x,zzero,tx,desc_data,info) call psb_geaxpby(zone,y,zzero,ty,desc_data,info) call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case('U') if (.not.present(initu)) then @@ -155,7 +155,7 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(zone,x,zzero,tx,desc_data,info) call psb_geaxpby(zone,initu,zzero,ty,desc_data,info) call psb_spmm(-zone,sm%nd,ty,zone,tx,desc_data,info,work=aux,trans=trans_) - call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') case default call psb_errpush(psb_err_internal_error_,name,& @@ -174,7 +174,7 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,info,init='Y') + call sm%sv%apply(zone,tx,zzero,ty,desc_data,trans_,aux,wv(3:),info,init='Y') if (info /= psb_success_) exit end do diff --git a/mlprec/impl/solver/mld_c_base_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_base_solver_apply_vect.f90 index c76ff70f..9213ecd4 100644 --- a/mlprec/impl/solver/mld_c_base_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_c_base_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_c_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_c_base_solver_mod, mld_protect_name => mld_c_base_solver_apply_vect @@ -48,6 +48,7 @@ subroutine mld_c_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& complex(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu diff --git a/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 index 03a53dcb..78e73b9c 100644 --- a/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_c_gs_solver, mld_protect_name => mld_c_bwgs_solver_apply_vect @@ -48,12 +48,13 @@ subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& complex(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, itx - type(psb_c_vect_type) :: wv, xit + type(psb_c_vect_type) :: tw, xit complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) complex(psb_spk_), allocatable :: temp(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -120,7 +121,7 @@ subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) select case (init_) case('Z') @@ -148,11 +149,11 @@ subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& ! ! do itx=1,sv%sweeps - call psb_geaxpby(cone,x,czero,wv,desc_data,info) + call psb_geaxpby(cone,x,czero,tw,desc_data,info) ! Update with L. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-cone,sv%l,xit,cone,wv,desc_data,info,doswap=.false.) - call psb_spsm(cone,sv%u,wv,czero,xit,desc_data,info) + call psb_spmm(-cone,sv%l,xit,cone,tw,desc_data,info,doswap=.false.) + call psb_spsm(cone,sv%u,tw,czero,xit,desc_data,info) end do call psb_geaxpby(alpha,xit,beta,y,desc_data,info) @@ -166,21 +167,6 @@ subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if -!!$ case('T') -!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,& -!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) -!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) -!!$ -!!$ case('C') -!!$ -!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) -!!$ -!!$ call wv1%mlt(cone,sv%dv,wv,czero,info,conjgx=trans_) -!!$ -!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) case default info = psb_err_internal_error_ @@ -196,7 +182,7 @@ subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& & a_err='Error in subsolve') goto 9999 endif - call wv%free(info) + call tw%free(info) call xit%free(info) if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then diff --git a/mlprec/impl/solver/mld_c_diag_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_diag_solver_apply_vect.f90 index 9ae556c2..8260ce8d 100644 --- a/mlprec/impl/solver/mld_c_diag_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_c_diag_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_c_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_c_diag_solver, mld_protect_name => mld_c_diag_solver_apply_vect @@ -48,6 +48,7 @@ subroutine mld_c_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& complex(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu diff --git a/mlprec/impl/solver/mld_c_gs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_gs_solver_apply_vect.f90 index 30162f5d..aeba1ae5 100644 --- a/mlprec/impl/solver/mld_c_gs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_c_gs_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_c_gs_solver, mld_protect_name => mld_c_gs_solver_apply_vect @@ -48,12 +48,13 @@ subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& complex(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, itx - type(psb_c_vect_type) :: wv, xit + type(psb_c_vect_type) :: tw, xit complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) complex(psb_spk_), allocatable :: temp(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -120,7 +121,7 @@ subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) select case (init_) case('Z') @@ -148,11 +149,11 @@ subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& ! ! do itx=1,sv%sweeps - call psb_geaxpby(cone,x,czero,wv,desc_data,info) + call psb_geaxpby(cone,x,czero,tw,desc_data,info) ! Update with U. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-cone,sv%u,xit,cone,wv,desc_data,info,doswap=.false.) - call psb_spsm(cone,sv%l,wv,czero,xit,desc_data,info) + call psb_spmm(-cone,sv%u,xit,cone,tw,desc_data,info,doswap=.false.) + call psb_spsm(cone,sv%l,tw,czero,xit,desc_data,info) end do call psb_geaxpby(alpha,xit,beta,y,desc_data,info) @@ -166,21 +167,6 @@ subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if -!!$ case('T') -!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,& -!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) -!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) -!!$ -!!$ case('C') -!!$ -!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) -!!$ -!!$ call wv1%mlt(cone,sv%dv,wv,czero,info,conjgx=trans_) -!!$ -!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) case default info = psb_err_internal_error_ @@ -196,7 +182,7 @@ subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& & a_err='Error in subsolve') goto 9999 endif - call wv%free(info) + call tw%free(info) call xit%free(info) if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then diff --git a/mlprec/impl/solver/mld_c_id_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_id_solver_apply_vect.f90 index ed10759c..0577949f 100644 --- a/mlprec/impl/solver/mld_c_id_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_c_id_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_c_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_c_id_solver, mld_protect_name => mld_c_id_solver_apply_vect @@ -48,6 +48,7 @@ subroutine mld_c_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& complex(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu diff --git a/mlprec/impl/solver/mld_c_ilu_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_ilu_solver_apply_vect.f90 index d94d1788..953fd757 100644 --- a/mlprec/impl/solver/mld_c_ilu_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_c_ilu_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_c_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_c_ilu_solver, mld_protect_name => mld_c_ilu_solver_apply_vect @@ -48,12 +48,13 @@ subroutine mld_c_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& complex(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col - type(psb_c_vect_type) :: wv, wv1 + type(psb_c_vect_type) :: tw, tw1 complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act character :: trans_ @@ -124,31 +125,31 @@ subroutine mld_c_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(wv1,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(tw1,desc_data,info,mold=x%v,scratch=.true.) select case(trans_) case('N') - call psb_spsm(cone,sv%l,x,czero,wv,desc_data,info,& + call psb_spsm(cone,sv%l,x,czero,tw,desc_data,info,& & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) - if (info == psb_success_) call psb_spsm(alpha,sv%u,wv,beta,y,desc_data,info,& + if (info == psb_success_) call psb_spsm(alpha,sv%u,tw,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_, work=aux) case('T') - call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,& + call psb_spsm(cone,sv%u,x,czero,tw,desc_data,info,& & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) - if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& + if (info == psb_success_) call psb_spsm(alpha,sv%l,tw,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) case('C') - call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,& + call psb_spsm(cone,sv%u,x,czero,tw,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) - call wv1%mlt(cone,sv%dv,wv,czero,info,conjgx=trans_) + call tw1%mlt(cone,sv%dv,tw,czero,info,conjgx=trans_) - if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& + if (info == psb_success_) call psb_spsm(alpha,sv%l,tw1,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) case default @@ -164,8 +165,8 @@ subroutine mld_c_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& & a_err='Error in subsolve') goto 9999 endif - call wv%free(info) - call wv1%free(info) + call tw%free(info) + call tw1%free(info) if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then else diff --git a/mlprec/impl/solver/mld_c_mumps_solver_apply_vect.F90 b/mlprec/impl/solver/mld_c_mumps_solver_apply_vect.F90 index 705ab9ac..09837530 100644 --- a/mlprec/impl/solver/mld_c_mumps_solver_apply_vect.F90 +++ b/mlprec/impl/solver/mld_c_mumps_solver_apply_vect.F90 @@ -40,7 +40,7 @@ ! ! subroutine c_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_c_mumps_solver implicit none @@ -49,8 +49,9 @@ subroutine c_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& type(psb_c_vect_type),intent(inout) :: x type(psb_c_vect_type),intent(inout) :: y complex(psb_spk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans + character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu diff --git a/mlprec/impl/solver/mld_d_base_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_base_solver_apply_vect.f90 index 41b0324b..41da5bc7 100644 --- a/mlprec/impl/solver/mld_d_base_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_d_base_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_d_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_d_base_solver_mod, mld_protect_name => mld_d_base_solver_apply_vect @@ -48,6 +48,7 @@ subroutine mld_d_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& real(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu diff --git a/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 index f12b1660..23dfe512 100644 --- a/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_d_gs_solver, mld_protect_name => mld_d_bwgs_solver_apply_vect @@ -48,12 +48,13 @@ subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& real(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, itx - type(psb_d_vect_type) :: wv, xit + type(psb_d_vect_type) :: tw, xit real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) real(psb_dpk_), allocatable :: temp(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -120,7 +121,7 @@ subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) select case (init_) case('Z') @@ -148,11 +149,11 @@ subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& ! ! do itx=1,sv%sweeps - call psb_geaxpby(done,x,dzero,wv,desc_data,info) + call psb_geaxpby(done,x,dzero,tw,desc_data,info) ! Update with L. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-done,sv%l,xit,done,wv,desc_data,info,doswap=.false.) - call psb_spsm(done,sv%u,wv,dzero,xit,desc_data,info) + call psb_spmm(-done,sv%l,xit,done,tw,desc_data,info,doswap=.false.) + call psb_spsm(done,sv%u,tw,dzero,xit,desc_data,info) end do call psb_geaxpby(alpha,xit,beta,y,desc_data,info) @@ -166,21 +167,6 @@ subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if -!!$ case('T') -!!$ call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,& -!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) -!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) -!!$ -!!$ case('C') -!!$ -!!$ call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) -!!$ -!!$ call wv1%mlt(done,sv%dv,wv,dzero,info,conjgx=trans_) -!!$ -!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) case default info = psb_err_internal_error_ @@ -196,7 +182,7 @@ subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& & a_err='Error in subsolve') goto 9999 endif - call wv%free(info) + call tw%free(info) call xit%free(info) if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then diff --git a/mlprec/impl/solver/mld_d_diag_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_diag_solver_apply_vect.f90 index 642b6cbf..3dc8bf33 100644 --- a/mlprec/impl/solver/mld_d_diag_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_d_diag_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_d_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_d_diag_solver, mld_protect_name => mld_d_diag_solver_apply_vect @@ -48,6 +48,7 @@ subroutine mld_d_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& real(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu diff --git a/mlprec/impl/solver/mld_d_gs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_gs_solver_apply_vect.f90 index 57b90fc7..b03cb55d 100644 --- a/mlprec/impl/solver/mld_d_gs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_d_gs_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_d_gs_solver, mld_protect_name => mld_d_gs_solver_apply_vect @@ -48,12 +48,13 @@ subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& real(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, itx - type(psb_d_vect_type) :: wv, xit + type(psb_d_vect_type) :: tw, xit real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) real(psb_dpk_), allocatable :: temp(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -120,7 +121,7 @@ subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) select case (init_) case('Z') @@ -148,11 +149,11 @@ subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& ! ! do itx=1,sv%sweeps - call psb_geaxpby(done,x,dzero,wv,desc_data,info) + call psb_geaxpby(done,x,dzero,tw,desc_data,info) ! Update with U. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-done,sv%u,xit,done,wv,desc_data,info,doswap=.false.) - call psb_spsm(done,sv%l,wv,dzero,xit,desc_data,info) + call psb_spmm(-done,sv%u,xit,done,tw,desc_data,info,doswap=.false.) + call psb_spsm(done,sv%l,tw,dzero,xit,desc_data,info) end do call psb_geaxpby(alpha,xit,beta,y,desc_data,info) @@ -166,21 +167,6 @@ subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if -!!$ case('T') -!!$ call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,& -!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) -!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) -!!$ -!!$ case('C') -!!$ -!!$ call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) -!!$ -!!$ call wv1%mlt(done,sv%dv,wv,dzero,info,conjgx=trans_) -!!$ -!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) case default info = psb_err_internal_error_ @@ -196,7 +182,7 @@ subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& & a_err='Error in subsolve') goto 9999 endif - call wv%free(info) + call tw%free(info) call xit%free(info) if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then diff --git a/mlprec/impl/solver/mld_d_id_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_id_solver_apply_vect.f90 index 931b5133..3bd58740 100644 --- a/mlprec/impl/solver/mld_d_id_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_d_id_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_d_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_d_id_solver, mld_protect_name => mld_d_id_solver_apply_vect @@ -48,6 +48,7 @@ subroutine mld_d_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& real(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu diff --git a/mlprec/impl/solver/mld_d_ilu_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_ilu_solver_apply_vect.f90 index 04a4de75..5957613f 100644 --- a/mlprec/impl/solver/mld_d_ilu_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_d_ilu_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_d_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_d_ilu_solver, mld_protect_name => mld_d_ilu_solver_apply_vect @@ -48,12 +48,13 @@ subroutine mld_d_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& real(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col - type(psb_d_vect_type) :: wv, wv1 + type(psb_d_vect_type) :: tw, tw1 real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act character :: trans_ @@ -124,31 +125,31 @@ subroutine mld_d_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(wv1,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(tw1,desc_data,info,mold=x%v,scratch=.true.) select case(trans_) case('N') - call psb_spsm(done,sv%l,x,dzero,wv,desc_data,info,& + call psb_spsm(done,sv%l,x,dzero,tw,desc_data,info,& & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) - if (info == psb_success_) call psb_spsm(alpha,sv%u,wv,beta,y,desc_data,info,& + if (info == psb_success_) call psb_spsm(alpha,sv%u,tw,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_, work=aux) case('T') - call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,& + call psb_spsm(done,sv%u,x,dzero,tw,desc_data,info,& & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) - if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& + if (info == psb_success_) call psb_spsm(alpha,sv%l,tw,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) case('C') - call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,& + call psb_spsm(done,sv%u,x,dzero,tw,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) - call wv1%mlt(done,sv%dv,wv,dzero,info,conjgx=trans_) + call tw1%mlt(done,sv%dv,tw,dzero,info,conjgx=trans_) - if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& + if (info == psb_success_) call psb_spsm(alpha,sv%l,tw1,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) case default @@ -164,8 +165,8 @@ subroutine mld_d_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& & a_err='Error in subsolve') goto 9999 endif - call wv%free(info) - call wv1%free(info) + call tw%free(info) + call tw1%free(info) if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then else diff --git a/mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90 b/mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90 index 9323c0d5..f6a32475 100644 --- a/mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90 +++ b/mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90 @@ -40,7 +40,7 @@ ! ! subroutine d_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_d_mumps_solver implicit none @@ -49,8 +49,9 @@ subroutine d_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& type(psb_d_vect_type),intent(inout) :: x type(psb_d_vect_type),intent(inout) :: y real(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans + character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu diff --git a/mlprec/impl/solver/mld_s_base_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_base_solver_apply_vect.f90 index 38cfae08..39532238 100644 --- a/mlprec/impl/solver/mld_s_base_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_s_base_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_s_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_s_base_solver_mod, mld_protect_name => mld_s_base_solver_apply_vect @@ -48,6 +48,7 @@ subroutine mld_s_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& real(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu diff --git a/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 index fa4a8d9b..02236ce7 100644 --- a/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_s_gs_solver, mld_protect_name => mld_s_bwgs_solver_apply_vect @@ -48,12 +48,13 @@ subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& real(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, itx - type(psb_s_vect_type) :: wv, xit + type(psb_s_vect_type) :: tw, xit real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) real(psb_spk_), allocatable :: temp(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -120,7 +121,7 @@ subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) select case (init_) case('Z') @@ -148,11 +149,11 @@ subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& ! ! do itx=1,sv%sweeps - call psb_geaxpby(sone,x,szero,wv,desc_data,info) + call psb_geaxpby(sone,x,szero,tw,desc_data,info) ! Update with L. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-sone,sv%l,xit,sone,wv,desc_data,info,doswap=.false.) - call psb_spsm(sone,sv%u,wv,szero,xit,desc_data,info) + call psb_spmm(-sone,sv%l,xit,sone,tw,desc_data,info,doswap=.false.) + call psb_spsm(sone,sv%u,tw,szero,xit,desc_data,info) end do call psb_geaxpby(alpha,xit,beta,y,desc_data,info) @@ -166,21 +167,6 @@ subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if -!!$ case('T') -!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,& -!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) -!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) -!!$ -!!$ case('C') -!!$ -!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) -!!$ -!!$ call wv1%mlt(sone,sv%dv,wv,szero,info,conjgx=trans_) -!!$ -!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) case default info = psb_err_internal_error_ @@ -196,7 +182,7 @@ subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& & a_err='Error in subsolve') goto 9999 endif - call wv%free(info) + call tw%free(info) call xit%free(info) if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then diff --git a/mlprec/impl/solver/mld_s_diag_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_diag_solver_apply_vect.f90 index 7b3a17db..920f85b9 100644 --- a/mlprec/impl/solver/mld_s_diag_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_s_diag_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_s_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_s_diag_solver, mld_protect_name => mld_s_diag_solver_apply_vect @@ -48,6 +48,7 @@ subroutine mld_s_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& real(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu diff --git a/mlprec/impl/solver/mld_s_gs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_gs_solver_apply_vect.f90 index 669c143c..36e676fb 100644 --- a/mlprec/impl/solver/mld_s_gs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_s_gs_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_s_gs_solver, mld_protect_name => mld_s_gs_solver_apply_vect @@ -48,12 +48,13 @@ subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& real(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, itx - type(psb_s_vect_type) :: wv, xit + type(psb_s_vect_type) :: tw, xit real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) real(psb_spk_), allocatable :: temp(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -120,7 +121,7 @@ subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) select case (init_) case('Z') @@ -148,11 +149,11 @@ subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& ! ! do itx=1,sv%sweeps - call psb_geaxpby(sone,x,szero,wv,desc_data,info) + call psb_geaxpby(sone,x,szero,tw,desc_data,info) ! Update with U. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-sone,sv%u,xit,sone,wv,desc_data,info,doswap=.false.) - call psb_spsm(sone,sv%l,wv,szero,xit,desc_data,info) + call psb_spmm(-sone,sv%u,xit,sone,tw,desc_data,info,doswap=.false.) + call psb_spsm(sone,sv%l,tw,szero,xit,desc_data,info) end do call psb_geaxpby(alpha,xit,beta,y,desc_data,info) @@ -166,21 +167,6 @@ subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if -!!$ case('T') -!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,& -!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) -!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) -!!$ -!!$ case('C') -!!$ -!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) -!!$ -!!$ call wv1%mlt(sone,sv%dv,wv,szero,info,conjgx=trans_) -!!$ -!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) case default info = psb_err_internal_error_ @@ -196,7 +182,7 @@ subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& & a_err='Error in subsolve') goto 9999 endif - call wv%free(info) + call tw%free(info) call xit%free(info) if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then diff --git a/mlprec/impl/solver/mld_s_id_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_id_solver_apply_vect.f90 index 8c590466..4d00f04d 100644 --- a/mlprec/impl/solver/mld_s_id_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_s_id_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_s_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_s_id_solver, mld_protect_name => mld_s_id_solver_apply_vect @@ -48,6 +48,7 @@ subroutine mld_s_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& real(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu diff --git a/mlprec/impl/solver/mld_s_ilu_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_ilu_solver_apply_vect.f90 index bebd4941..b5038235 100644 --- a/mlprec/impl/solver/mld_s_ilu_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_s_ilu_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_s_ilu_solver, mld_protect_name => mld_s_ilu_solver_apply_vect @@ -48,12 +48,13 @@ subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& real(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col - type(psb_s_vect_type) :: wv, wv1 + type(psb_s_vect_type) :: tw, tw1 real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act character :: trans_ @@ -124,31 +125,31 @@ subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(wv1,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(tw1,desc_data,info,mold=x%v,scratch=.true.) select case(trans_) case('N') - call psb_spsm(sone,sv%l,x,szero,wv,desc_data,info,& + call psb_spsm(sone,sv%l,x,szero,tw,desc_data,info,& & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) - if (info == psb_success_) call psb_spsm(alpha,sv%u,wv,beta,y,desc_data,info,& + if (info == psb_success_) call psb_spsm(alpha,sv%u,tw,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_, work=aux) case('T') - call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,& + call psb_spsm(sone,sv%u,x,szero,tw,desc_data,info,& & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) - if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& + if (info == psb_success_) call psb_spsm(alpha,sv%l,tw,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) case('C') - call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,& + call psb_spsm(sone,sv%u,x,szero,tw,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) - call wv1%mlt(sone,sv%dv,wv,szero,info,conjgx=trans_) + call tw1%mlt(sone,sv%dv,tw,szero,info,conjgx=trans_) - if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& + if (info == psb_success_) call psb_spsm(alpha,sv%l,tw1,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) case default @@ -164,8 +165,8 @@ subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& & a_err='Error in subsolve') goto 9999 endif - call wv%free(info) - call wv1%free(info) + call tw%free(info) + call tw1%free(info) if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then else diff --git a/mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90 b/mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90 index 9da0aab3..91addbbc 100644 --- a/mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90 +++ b/mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90 @@ -40,7 +40,7 @@ ! ! subroutine s_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_s_mumps_solver implicit none @@ -49,8 +49,9 @@ subroutine s_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& type(psb_s_vect_type),intent(inout) :: x type(psb_s_vect_type),intent(inout) :: y real(psb_spk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans + character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu diff --git a/mlprec/impl/solver/mld_z_base_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_base_solver_apply_vect.f90 index f6a5eb76..c4ea18cf 100644 --- a/mlprec/impl/solver/mld_z_base_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_z_base_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_z_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_z_base_solver_mod, mld_protect_name => mld_z_base_solver_apply_vect @@ -48,6 +48,7 @@ subroutine mld_z_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& complex(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu diff --git a/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 index 805e7c84..76c188dc 100644 --- a/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_z_gs_solver, mld_protect_name => mld_z_bwgs_solver_apply_vect @@ -48,12 +48,13 @@ subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& complex(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, itx - type(psb_z_vect_type) :: wv, xit + type(psb_z_vect_type) :: tw, xit complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) complex(psb_dpk_), allocatable :: temp(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -120,7 +121,7 @@ subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) select case (init_) case('Z') @@ -148,11 +149,11 @@ subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& ! ! do itx=1,sv%sweeps - call psb_geaxpby(zone,x,zzero,wv,desc_data,info) + call psb_geaxpby(zone,x,zzero,tw,desc_data,info) ! Update with L. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-zone,sv%l,xit,zone,wv,desc_data,info,doswap=.false.) - call psb_spsm(zone,sv%u,wv,zzero,xit,desc_data,info) + call psb_spmm(-zone,sv%l,xit,zone,tw,desc_data,info,doswap=.false.) + call psb_spsm(zone,sv%u,tw,zzero,xit,desc_data,info) end do call psb_geaxpby(alpha,xit,beta,y,desc_data,info) @@ -166,21 +167,6 @@ subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if -!!$ case('T') -!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,& -!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) -!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) -!!$ -!!$ case('C') -!!$ -!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) -!!$ -!!$ call wv1%mlt(zone,sv%dv,wv,zzero,info,conjgx=trans_) -!!$ -!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) case default info = psb_err_internal_error_ @@ -196,7 +182,7 @@ subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& & a_err='Error in subsolve') goto 9999 endif - call wv%free(info) + call tw%free(info) call xit%free(info) if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then diff --git a/mlprec/impl/solver/mld_z_diag_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_diag_solver_apply_vect.f90 index 62027f21..1fee862a 100644 --- a/mlprec/impl/solver/mld_z_diag_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_z_diag_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_z_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_z_diag_solver, mld_protect_name => mld_z_diag_solver_apply_vect @@ -48,6 +48,7 @@ subroutine mld_z_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& complex(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu diff --git a/mlprec/impl/solver/mld_z_gs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_gs_solver_apply_vect.f90 index b5c79879..ad56461e 100644 --- a/mlprec/impl/solver/mld_z_gs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_z_gs_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_z_gs_solver, mld_protect_name => mld_z_gs_solver_apply_vect @@ -48,12 +48,13 @@ subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& complex(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, itx - type(psb_z_vect_type) :: wv, xit + type(psb_z_vect_type) :: tw, xit complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) complex(psb_dpk_), allocatable :: temp(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -120,7 +121,7 @@ subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) select case (init_) case('Z') @@ -148,11 +149,11 @@ subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& ! ! do itx=1,sv%sweeps - call psb_geaxpby(zone,x,zzero,wv,desc_data,info) + call psb_geaxpby(zone,x,zzero,tw,desc_data,info) ! Update with U. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-zone,sv%u,xit,zone,wv,desc_data,info,doswap=.false.) - call psb_spsm(zone,sv%l,wv,zzero,xit,desc_data,info) + call psb_spmm(-zone,sv%u,xit,zone,tw,desc_data,info,doswap=.false.) + call psb_spsm(zone,sv%l,tw,zzero,xit,desc_data,info) end do call psb_geaxpby(alpha,xit,beta,y,desc_data,info) @@ -166,21 +167,6 @@ subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if -!!$ case('T') -!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,& -!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) -!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) -!!$ -!!$ case('C') -!!$ -!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) -!!$ -!!$ call wv1%mlt(zone,sv%dv,wv,zzero,info,conjgx=trans_) -!!$ -!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& -!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) case default info = psb_err_internal_error_ @@ -196,7 +182,7 @@ subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& & a_err='Error in subsolve') goto 9999 endif - call wv%free(info) + call tw%free(info) call xit%free(info) if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then diff --git a/mlprec/impl/solver/mld_z_id_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_id_solver_apply_vect.f90 index 01f5f874..53aa8848 100644 --- a/mlprec/impl/solver/mld_z_id_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_z_id_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_z_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_z_id_solver, mld_protect_name => mld_z_id_solver_apply_vect @@ -48,6 +48,7 @@ subroutine mld_z_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& complex(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu diff --git a/mlprec/impl/solver/mld_z_ilu_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_ilu_solver_apply_vect.f90 index 905a27d8..980c777f 100644 --- a/mlprec/impl/solver/mld_z_ilu_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_z_ilu_solver_apply_vect.f90 @@ -36,7 +36,7 @@ ! ! subroutine mld_z_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_z_ilu_solver, mld_protect_name => mld_z_ilu_solver_apply_vect @@ -48,12 +48,13 @@ subroutine mld_z_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& complex(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col - type(psb_z_vect_type) :: wv, wv1 + type(psb_z_vect_type) :: tw, tw1 complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act character :: trans_ @@ -124,31 +125,31 @@ subroutine mld_z_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(wv1,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(tw1,desc_data,info,mold=x%v,scratch=.true.) select case(trans_) case('N') - call psb_spsm(zone,sv%l,x,zzero,wv,desc_data,info,& + call psb_spsm(zone,sv%l,x,zzero,tw,desc_data,info,& & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) - if (info == psb_success_) call psb_spsm(alpha,sv%u,wv,beta,y,desc_data,info,& + if (info == psb_success_) call psb_spsm(alpha,sv%u,tw,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_, work=aux) case('T') - call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,& + call psb_spsm(zone,sv%u,x,zzero,tw,desc_data,info,& & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) - if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& + if (info == psb_success_) call psb_spsm(alpha,sv%l,tw,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) case('C') - call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,& + call psb_spsm(zone,sv%u,x,zzero,tw,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) - call wv1%mlt(zone,sv%dv,wv,zzero,info,conjgx=trans_) + call tw1%mlt(zone,sv%dv,tw,zzero,info,conjgx=trans_) - if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& + if (info == psb_success_) call psb_spsm(alpha,sv%l,tw1,beta,y,desc_data,info,& & trans=trans_,scale='U',choice=psb_none_,work=aux) case default @@ -164,8 +165,8 @@ subroutine mld_z_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& & a_err='Error in subsolve') goto 9999 endif - call wv%free(info) - call wv1%free(info) + call tw%free(info) + call tw1%free(info) if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then else diff --git a/mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90 b/mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90 index 5d22ea76..f2780919 100644 --- a/mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90 +++ b/mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90 @@ -40,7 +40,7 @@ ! ! subroutine z_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod use mld_z_mumps_solver implicit none @@ -49,8 +49,9 @@ subroutine z_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& type(psb_z_vect_type),intent(inout) :: x type(psb_z_vect_type),intent(inout) :: y complex(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans + character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_c_base_solver_mod.f90 b/mlprec/mld_c_base_solver_mod.f90 index 299f547c..5c995214 100644 --- a/mlprec/mld_c_base_solver_mod.f90 +++ b/mlprec/mld_c_base_solver_mod.f90 @@ -143,7 +143,7 @@ module mld_c_base_solver_mod interface subroutine mld_c_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & & mld_c_base_solver_type, psb_ipk_ @@ -155,6 +155,7 @@ module mld_c_base_solver_mod complex(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_c_diag_solver.f90 b/mlprec/mld_c_diag_solver.f90 index 2a2b3630..c386f7e1 100644 --- a/mlprec/mld_c_diag_solver.f90 +++ b/mlprec/mld_c_diag_solver.f90 @@ -76,7 +76,7 @@ module mld_c_diag_solver interface subroutine mld_c_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & & mld_c_diag_solver_type, psb_ipk_ @@ -87,6 +87,7 @@ module mld_c_diag_solver complex(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_c_gs_solver.f90 b/mlprec/mld_c_gs_solver.f90 index f8a8d3bb..7d0b6a50 100644 --- a/mlprec/mld_c_gs_solver.f90 +++ b/mlprec/mld_c_gs_solver.f90 @@ -107,7 +107,7 @@ module mld_c_gs_solver interface subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, mld_c_gs_solver_type, psb_c_vect_type, psb_spk_, & & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_ implicit none @@ -118,12 +118,13 @@ module mld_c_gs_solver complex(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu end subroutine mld_c_gs_solver_apply_vect subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, mld_c_bwgs_solver_type, psb_c_vect_type, psb_spk_, & & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_ implicit none @@ -134,6 +135,7 @@ module mld_c_gs_solver complex(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_c_id_solver.f90 b/mlprec/mld_c_id_solver.f90 index b17bd7a1..a64a0f30 100644 --- a/mlprec/mld_c_id_solver.f90 +++ b/mlprec/mld_c_id_solver.f90 @@ -64,7 +64,7 @@ module mld_c_id_solver interface subroutine mld_c_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & & mld_c_id_solver_type, psb_ipk_ @@ -75,6 +75,7 @@ module mld_c_id_solver complex(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_c_ilu_solver.f90 b/mlprec/mld_c_ilu_solver.f90 index f7a63066..43f8365b 100644 --- a/mlprec/mld_c_ilu_solver.f90 +++ b/mlprec/mld_c_ilu_solver.f90 @@ -103,7 +103,7 @@ module mld_c_ilu_solver interface subroutine mld_c_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, mld_c_ilu_solver_type, psb_c_vect_type, psb_spk_, & & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_ implicit none @@ -114,6 +114,7 @@ module mld_c_ilu_solver complex(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_c_mumps_solver.F90 b/mlprec/mld_c_mumps_solver.F90 index 3c0a5eae..1cef6958 100644 --- a/mlprec/mld_c_mumps_solver.F90 +++ b/mlprec/mld_c_mumps_solver.F90 @@ -103,7 +103,7 @@ module mld_c_mumps_solver interface subroutine c_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, mld_c_mumps_solver_type, psb_c_vect_type, psb_dpk_, psb_spk_, & & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_ implicit none @@ -112,8 +112,9 @@ module mld_c_mumps_solver type(psb_c_vect_type),intent(inout) :: x type(psb_c_vect_type),intent(inout) :: y complex(psb_spk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans + character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) + type(psb_c_vect_type),intent(inout) :: wv(:) integer, intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_c_slu_solver.F90 b/mlprec/mld_c_slu_solver.F90 index 5336269d..a6fa4062 100644 --- a/mlprec/mld_c_slu_solver.F90 +++ b/mlprec/mld_c_slu_solver.F90 @@ -211,7 +211,7 @@ contains end subroutine c_slu_solver_apply subroutine c_slu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -219,9 +219,10 @@ contains type(psb_c_vect_type),intent(inout) :: x type(psb_c_vect_type),intent(inout) :: y complex(psb_spk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans + character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) - integer, intent(out) :: info + type(psb_c_vect_type),intent(inout) :: wv(:) + integer, intent(out) :: info character, intent(in), optional :: init type(psb_c_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_d_base_solver_mod.f90 b/mlprec/mld_d_base_solver_mod.f90 index e3a0242c..49822770 100644 --- a/mlprec/mld_d_base_solver_mod.f90 +++ b/mlprec/mld_d_base_solver_mod.f90 @@ -143,7 +143,7 @@ module mld_d_base_solver_mod interface subroutine mld_d_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & & mld_d_base_solver_type, psb_ipk_ @@ -155,6 +155,7 @@ module mld_d_base_solver_mod real(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_d_diag_solver.f90 b/mlprec/mld_d_diag_solver.f90 index cb12f850..fcf5a0bc 100644 --- a/mlprec/mld_d_diag_solver.f90 +++ b/mlprec/mld_d_diag_solver.f90 @@ -76,7 +76,7 @@ module mld_d_diag_solver interface subroutine mld_d_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & & mld_d_diag_solver_type, psb_ipk_ @@ -87,6 +87,7 @@ module mld_d_diag_solver real(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_d_gs_solver.f90 b/mlprec/mld_d_gs_solver.f90 index 2c53ef10..ac15e710 100644 --- a/mlprec/mld_d_gs_solver.f90 +++ b/mlprec/mld_d_gs_solver.f90 @@ -107,7 +107,7 @@ module mld_d_gs_solver interface subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, mld_d_gs_solver_type, psb_d_vect_type, psb_dpk_, & & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_ implicit none @@ -118,12 +118,13 @@ module mld_d_gs_solver real(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu end subroutine mld_d_gs_solver_apply_vect subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, mld_d_bwgs_solver_type, psb_d_vect_type, psb_dpk_, & & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_ implicit none @@ -134,6 +135,7 @@ module mld_d_gs_solver real(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_d_id_solver.f90 b/mlprec/mld_d_id_solver.f90 index 17e7c46d..36e19011 100644 --- a/mlprec/mld_d_id_solver.f90 +++ b/mlprec/mld_d_id_solver.f90 @@ -64,7 +64,7 @@ module mld_d_id_solver interface subroutine mld_d_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & & mld_d_id_solver_type, psb_ipk_ @@ -75,6 +75,7 @@ module mld_d_id_solver real(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_d_ilu_solver.f90 b/mlprec/mld_d_ilu_solver.f90 index 6fff1dd9..4fd0c9f0 100644 --- a/mlprec/mld_d_ilu_solver.f90 +++ b/mlprec/mld_d_ilu_solver.f90 @@ -103,7 +103,7 @@ module mld_d_ilu_solver interface subroutine mld_d_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, mld_d_ilu_solver_type, psb_d_vect_type, psb_dpk_, & & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_ implicit none @@ -114,6 +114,7 @@ module mld_d_ilu_solver real(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_d_mumps_solver.F90 b/mlprec/mld_d_mumps_solver.F90 index 54d18367..e8656878 100644 --- a/mlprec/mld_d_mumps_solver.F90 +++ b/mlprec/mld_d_mumps_solver.F90 @@ -103,7 +103,7 @@ module mld_d_mumps_solver interface subroutine d_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, mld_d_mumps_solver_type, psb_d_vect_type, psb_dpk_, psb_spk_, & & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_ implicit none @@ -112,8 +112,9 @@ module mld_d_mumps_solver type(psb_d_vect_type),intent(inout) :: x type(psb_d_vect_type),intent(inout) :: y real(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans + character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer, intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_d_slu_solver.F90 b/mlprec/mld_d_slu_solver.F90 index 7725fea3..0190fcd1 100644 --- a/mlprec/mld_d_slu_solver.F90 +++ b/mlprec/mld_d_slu_solver.F90 @@ -211,7 +211,7 @@ contains end subroutine d_slu_solver_apply subroutine d_slu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -219,9 +219,10 @@ contains type(psb_d_vect_type),intent(inout) :: x type(psb_d_vect_type),intent(inout) :: y real(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans + character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) - integer, intent(out) :: info + type(psb_d_vect_type),intent(inout) :: wv(:) + integer, intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_d_sludist_solver.F90 b/mlprec/mld_d_sludist_solver.F90 index 16da7f32..8fd5b17d 100644 --- a/mlprec/mld_d_sludist_solver.F90 +++ b/mlprec/mld_d_sludist_solver.F90 @@ -212,7 +212,7 @@ contains end subroutine d_sludist_solver_apply subroutine d_sludist_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -220,9 +220,10 @@ contains type(psb_d_vect_type),intent(inout) :: x type(psb_d_vect_type),intent(inout) :: y real(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans + character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) - integer, intent(out) :: info + type(psb_d_vect_type),intent(inout) :: wv(:) + integer, intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_d_umf_solver.F90 b/mlprec/mld_d_umf_solver.F90 index a1730755..3aa54370 100644 --- a/mlprec/mld_d_umf_solver.F90 +++ b/mlprec/mld_d_umf_solver.F90 @@ -215,7 +215,7 @@ contains end subroutine d_umf_solver_apply subroutine d_umf_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -223,8 +223,9 @@ contains type(psb_d_vect_type),intent(inout) :: x type(psb_d_vect_type),intent(inout) :: y real(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans + character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) + type(psb_d_vect_type),intent(inout) :: wv(:) integer, intent(out) :: info character, intent(in), optional :: init type(psb_d_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_s_base_solver_mod.f90 b/mlprec/mld_s_base_solver_mod.f90 index ebec407f..c561f4e8 100644 --- a/mlprec/mld_s_base_solver_mod.f90 +++ b/mlprec/mld_s_base_solver_mod.f90 @@ -143,7 +143,7 @@ module mld_s_base_solver_mod interface subroutine mld_s_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & & mld_s_base_solver_type, psb_ipk_ @@ -155,6 +155,7 @@ module mld_s_base_solver_mod real(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_s_diag_solver.f90 b/mlprec/mld_s_diag_solver.f90 index 6c437848..65534256 100644 --- a/mlprec/mld_s_diag_solver.f90 +++ b/mlprec/mld_s_diag_solver.f90 @@ -76,7 +76,7 @@ module mld_s_diag_solver interface subroutine mld_s_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & & mld_s_diag_solver_type, psb_ipk_ @@ -87,6 +87,7 @@ module mld_s_diag_solver real(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_s_gs_solver.f90 b/mlprec/mld_s_gs_solver.f90 index b3619ebf..833e8cdf 100644 --- a/mlprec/mld_s_gs_solver.f90 +++ b/mlprec/mld_s_gs_solver.f90 @@ -107,7 +107,7 @@ module mld_s_gs_solver interface subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, mld_s_gs_solver_type, psb_s_vect_type, psb_spk_, & & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_ implicit none @@ -118,12 +118,13 @@ module mld_s_gs_solver real(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu end subroutine mld_s_gs_solver_apply_vect subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, mld_s_bwgs_solver_type, psb_s_vect_type, psb_spk_, & & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_ implicit none @@ -134,6 +135,7 @@ module mld_s_gs_solver real(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_s_id_solver.f90 b/mlprec/mld_s_id_solver.f90 index 579722b7..cca48b2c 100644 --- a/mlprec/mld_s_id_solver.f90 +++ b/mlprec/mld_s_id_solver.f90 @@ -64,7 +64,7 @@ module mld_s_id_solver interface subroutine mld_s_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & & mld_s_id_solver_type, psb_ipk_ @@ -75,6 +75,7 @@ module mld_s_id_solver real(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_s_ilu_solver.f90 b/mlprec/mld_s_ilu_solver.f90 index 8c93fa8d..2c01b022 100644 --- a/mlprec/mld_s_ilu_solver.f90 +++ b/mlprec/mld_s_ilu_solver.f90 @@ -103,7 +103,7 @@ module mld_s_ilu_solver interface subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, mld_s_ilu_solver_type, psb_s_vect_type, psb_spk_, & & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_ implicit none @@ -114,6 +114,7 @@ module mld_s_ilu_solver real(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_s_mumps_solver.F90 b/mlprec/mld_s_mumps_solver.F90 index eee5e681..aec5feb5 100644 --- a/mlprec/mld_s_mumps_solver.F90 +++ b/mlprec/mld_s_mumps_solver.F90 @@ -103,7 +103,7 @@ module mld_s_mumps_solver interface subroutine s_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, mld_s_mumps_solver_type, psb_s_vect_type, psb_dpk_, psb_spk_, & & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_ implicit none @@ -112,8 +112,9 @@ module mld_s_mumps_solver type(psb_s_vect_type),intent(inout) :: x type(psb_s_vect_type),intent(inout) :: y real(psb_spk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans + character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) + type(psb_s_vect_type),intent(inout) :: wv(:) integer, intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_s_slu_solver.F90 b/mlprec/mld_s_slu_solver.F90 index 18a0035a..6b1d2ad7 100644 --- a/mlprec/mld_s_slu_solver.F90 +++ b/mlprec/mld_s_slu_solver.F90 @@ -211,7 +211,7 @@ contains end subroutine s_slu_solver_apply subroutine s_slu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -219,9 +219,10 @@ contains type(psb_s_vect_type),intent(inout) :: x type(psb_s_vect_type),intent(inout) :: y real(psb_spk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans + character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) - integer, intent(out) :: info + type(psb_s_vect_type),intent(inout) :: wv(:) + integer, intent(out) :: info character, intent(in), optional :: init type(psb_s_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_z_base_solver_mod.f90 b/mlprec/mld_z_base_solver_mod.f90 index 9a2b3836..636afdfc 100644 --- a/mlprec/mld_z_base_solver_mod.f90 +++ b/mlprec/mld_z_base_solver_mod.f90 @@ -143,7 +143,7 @@ module mld_z_base_solver_mod interface subroutine mld_z_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & & mld_z_base_solver_type, psb_ipk_ @@ -155,6 +155,7 @@ module mld_z_base_solver_mod complex(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_z_diag_solver.f90 b/mlprec/mld_z_diag_solver.f90 index ed5ea319..a82f9f4c 100644 --- a/mlprec/mld_z_diag_solver.f90 +++ b/mlprec/mld_z_diag_solver.f90 @@ -76,7 +76,7 @@ module mld_z_diag_solver interface subroutine mld_z_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & & mld_z_diag_solver_type, psb_ipk_ @@ -87,6 +87,7 @@ module mld_z_diag_solver complex(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_z_gs_solver.f90 b/mlprec/mld_z_gs_solver.f90 index de494bfa..c1a84669 100644 --- a/mlprec/mld_z_gs_solver.f90 +++ b/mlprec/mld_z_gs_solver.f90 @@ -107,7 +107,7 @@ module mld_z_gs_solver interface subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, mld_z_gs_solver_type, psb_z_vect_type, psb_dpk_, & & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_ implicit none @@ -118,12 +118,13 @@ module mld_z_gs_solver complex(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu end subroutine mld_z_gs_solver_apply_vect subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, mld_z_bwgs_solver_type, psb_z_vect_type, psb_dpk_, & & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_ implicit none @@ -134,6 +135,7 @@ module mld_z_gs_solver complex(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_z_id_solver.f90 b/mlprec/mld_z_id_solver.f90 index f429f10c..73986c40 100644 --- a/mlprec/mld_z_id_solver.f90 +++ b/mlprec/mld_z_id_solver.f90 @@ -64,7 +64,7 @@ module mld_z_id_solver interface subroutine mld_z_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & & mld_z_id_solver_type, psb_ipk_ @@ -75,6 +75,7 @@ module mld_z_id_solver complex(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_z_ilu_solver.f90 b/mlprec/mld_z_ilu_solver.f90 index c9635860..79a6f634 100644 --- a/mlprec/mld_z_ilu_solver.f90 +++ b/mlprec/mld_z_ilu_solver.f90 @@ -103,7 +103,7 @@ module mld_z_ilu_solver interface subroutine mld_z_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, mld_z_ilu_solver_type, psb_z_vect_type, psb_dpk_, & & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_ implicit none @@ -114,6 +114,7 @@ module mld_z_ilu_solver complex(psb_dpk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_z_mumps_solver.F90 b/mlprec/mld_z_mumps_solver.F90 index c3d926da..ff17298e 100644 --- a/mlprec/mld_z_mumps_solver.F90 +++ b/mlprec/mld_z_mumps_solver.F90 @@ -103,7 +103,7 @@ module mld_z_mumps_solver interface subroutine z_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) import :: psb_desc_type, mld_z_mumps_solver_type, psb_z_vect_type, psb_dpk_, psb_spk_, & & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_ implicit none @@ -112,8 +112,9 @@ module mld_z_mumps_solver type(psb_z_vect_type),intent(inout) :: x type(psb_z_vect_type),intent(inout) :: y complex(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans + character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer, intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_z_slu_solver.F90 b/mlprec/mld_z_slu_solver.F90 index cd601f4f..67a916c8 100644 --- a/mlprec/mld_z_slu_solver.F90 +++ b/mlprec/mld_z_slu_solver.F90 @@ -211,7 +211,7 @@ contains end subroutine z_slu_solver_apply subroutine z_slu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -219,9 +219,10 @@ contains type(psb_z_vect_type),intent(inout) :: x type(psb_z_vect_type),intent(inout) :: y complex(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans + character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) - integer, intent(out) :: info + type(psb_z_vect_type),intent(inout) :: wv(:) + integer, intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_z_sludist_solver.F90 b/mlprec/mld_z_sludist_solver.F90 index a833264e..4d103fd9 100644 --- a/mlprec/mld_z_sludist_solver.F90 +++ b/mlprec/mld_z_sludist_solver.F90 @@ -212,7 +212,7 @@ contains end subroutine z_sludist_solver_apply subroutine z_sludist_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -220,9 +220,10 @@ contains type(psb_z_vect_type),intent(inout) :: x type(psb_z_vect_type),intent(inout) :: y complex(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans + character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) - integer, intent(out) :: info + type(psb_z_vect_type),intent(inout) :: wv(:) + integer, intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu diff --git a/mlprec/mld_z_umf_solver.F90 b/mlprec/mld_z_umf_solver.F90 index 67f59ac9..37af31df 100644 --- a/mlprec/mld_z_umf_solver.F90 +++ b/mlprec/mld_z_umf_solver.F90 @@ -215,7 +215,7 @@ contains end subroutine z_umf_solver_apply subroutine z_umf_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info,init,initu) + & trans,work,wv,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -223,8 +223,9 @@ contains type(psb_z_vect_type),intent(inout) :: x type(psb_z_vect_type),intent(inout) :: y complex(psb_dpk_),intent(in) :: alpha,beta - character(len=1),intent(in) :: trans + character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) + type(psb_z_vect_type),intent(inout) :: wv(:) integer, intent(out) :: info character, intent(in), optional :: init type(psb_z_vect_type),intent(inout), optional :: initu From 68f5691a99c43649626ccc58b7944d76aeb7ea6d Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 12 Dec 2017 08:36:14 +0000 Subject: [PATCH 13/16] version of K-cycle working, but to be investigated further. --- mlprec/impl/mld_cmlprec_aply.f90 | 81 ++++++++++++++++++-------------- mlprec/impl/mld_dmlprec_aply.f90 | 81 ++++++++++++++++++-------------- mlprec/impl/mld_smlprec_aply.f90 | 81 ++++++++++++++++++-------------- mlprec/impl/mld_zmlprec_aply.f90 | 81 ++++++++++++++++++-------------- mlprec/mld_c_onelev_mod.f90 | 5 +- mlprec/mld_d_onelev_mod.f90 | 5 +- mlprec/mld_s_onelev_mod.f90 | 5 +- mlprec/mld_z_onelev_mod.f90 | 5 +- 8 files changed, 196 insertions(+), 148 deletions(-) diff --git a/mlprec/impl/mld_cmlprec_aply.f90 b/mlprec/impl/mld_cmlprec_aply.f90 index 3a961b37..f6118c99 100644 --- a/mlprec/impl/mld_cmlprec_aply.f90 +++ b/mlprec/impl/mld_cmlprec_aply.f90 @@ -847,7 +847,7 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& - & wv => p%precv(level)%wrk%wv) + & wv => p%precv(level)%wrk%wv(8:)) if (level == nlev) then ! ! Apply smoother @@ -1017,7 +1017,7 @@ contains !Other variables type(psb_c_vect_type) :: v, w, rhs, v1, x - type(psb_c_vect_type), dimension(0:1) :: d + type(psb_c_vect_type) :: d0, d1 complex(psb_spk_) :: delta_old, rhs_norm, alpha, tau, tau1, tau2, tau3, tau4, beta real(psb_spk_) :: l2_norm, delta, rtol=0.25, delta0, tnrm @@ -1025,37 +1025,50 @@ contains integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx character(len=20) :: name = 'innerit_k_cycle' + + if (size(p%precv(level)%wrk%wv)<7) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid wv size') + goto 9999 + end if + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& - & wv => p%precv(level)%wrk%wv) + & v => p%precv(level)%wrk%wv(1), & + & w => p%precv(level)%wrk%wv(2),& + & rhs => p%precv(level)%wrk%wv(3))!, & +!!$ & v1 => p%precv(level)%wrk%wv(4), & +!!$ & x => p%precv(level)%wrk%wv(5), & +!!$ & d0 => p%precv(level)%wrk%wv(1), & +!!$ & d1 => p%precv(level)%wrk%wv(2)) !Assemble rhs, w, v, v1, x - call psb_geasb(rhs,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) - call psb_geasb(w,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) - call psb_geasb(v,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) +!!$ call psb_geasb(rhs,& +!!$ & base_desc,info,& +!!$ & scratch=.true.,mold=vx2l%v) +!!$ call psb_geasb(w,& +!!$ & base_desc,info,& +!!$ & scratch=.true.,mold=vx2l%v) +!!$ call psb_geasb(v,& +!!$ & base_desc,info,& +!!$ & scratch=.true.,mold=vx2l%v) call psb_geasb(v1,& & base_desc,info,& & scratch=.true.,mold=vx2l%v) call psb_geasb(x,& & base_desc,info,& & scratch=.true.,mold=vx2l%v) - !Assemble d(0) and d(1) - call psb_geasb(d(0),& + !Assemble d0 and d1 + call psb_geasb(d0,& & base_desc,info,& & scratch=.true.,mold=vy2l%v) - call psb_geasb(d(1),& + call psb_geasb(d1,& & base_desc,info,& & scratch=.true.,mold=vy2l%v) - call x%zero() ! rhs=vx2l and w=rhs @@ -1080,9 +1093,9 @@ contains idx=0 call inner_ml_aply(level,p,trans,work,info) - call psb_geaxpby(cone,vy2l,czero,d(idx),base_desc,info) + call psb_geaxpby(cone,vy2l,czero,d0,base_desc,info) - call psb_spmm(cone,base_a,d(idx),czero,v,base_desc,info) + call psb_spmm(cone,base_a,d0,czero,v,base_desc,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') @@ -1091,8 +1104,8 @@ contains !FCG if (psb_toupper(trim(innersolv)) == 'FCG') then - delta_old = psb_gedot(d(idx), w, base_desc, info) - tau = psb_gedot(d(idx), v, base_desc, info) + delta_old = psb_gedot(d0, w, base_desc, info) + tau = psb_gedot(d0, v, base_desc, info) !GCR else if (psb_toupper(trim(innersolv)) == 'GCR') then delta_old = psb_gedot(v, w, base_desc, info) @@ -1112,7 +1125,7 @@ contains if (l2_norm <= rtol*delta0) then !Update solution x - call psb_geaxpby(alpha, d(idx), cone, x, base_desc, info) + call psb_geaxpby(alpha, d0, cone, x, base_desc, info) else iter = iter + 1 idx=mod(iter,2) @@ -1120,11 +1133,11 @@ contains !Apply preconditioner call psb_geaxpby(cone,w,czero,vx2l,base_desc,info) call inner_ml_aply(level,p,trans,work,info) - call psb_geaxpby(cone,vy2l,czero,d(idx),base_desc,info) + call psb_geaxpby(cone,vy2l,czero,d1,base_desc,info) !Sparse matrix vector product - call psb_spmm(cone,base_a,d(idx),czero,v1,base_desc,info) + call psb_spmm(cone,base_a,d1,czero,v1,base_desc,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') @@ -1133,9 +1146,9 @@ contains !tau1, tau2, tau3, tau4 if (psb_toupper(trim(innersolv)) == 'FCG') then - tau1= psb_gedot(d(idx), v, base_desc, info) - tau2= psb_gedot(d(idx), v1, base_desc, info) - tau3= psb_gedot(d(idx), w, base_desc, info) + tau1= psb_gedot(d1, v, base_desc, info) + tau2= psb_gedot(d1, v1, base_desc, info) + tau3= psb_gedot(d1, w, base_desc, info) tau4= tau2 - (tau1*tau1)/tau else if (psb_toupper(trim(innersolv)) == 'GCR') then tau1= psb_gedot(v1, v, base_desc, info) @@ -1150,19 +1163,20 @@ contains !Update solution alpha=alpha-(tau1*tau3)/(tau*tau4) - call psb_geaxpby(alpha,d(idx - 1),cone,x,base_desc,info) + call psb_geaxpby(alpha,d0,cone,x,base_desc,info) alpha=tau3/tau4 - call psb_geaxpby(alpha,d(idx),cone,x,base_desc,info) + call psb_geaxpby(alpha,d1,cone,x,base_desc,info) endif call psb_geaxpby(cone,x,czero,vy2l,base_desc,info) !Free vectors - call psb_gefree(v, base_desc, info) +!!$ call psb_gefree(v, base_desc, info) +!!$ call psb_gefree(w, base_desc, info) +!!$ call psb_gefree(rhs, base_desc, info) call psb_gefree(v1, base_desc, info) - call psb_gefree(w, base_desc, info) call psb_gefree(x, base_desc, info) - call psb_gefree(d(0), base_desc, info) - call psb_gefree(d(1), base_desc, info) + call psb_gefree(d0, base_desc, info) + call psb_gefree(d1, base_desc, info) end associate 9999 continue call psb_erractionrestore(err_act) @@ -1176,9 +1190,6 @@ contains end subroutine mld_cmlprec_aply_vect - - - ! ! Old routine for arrays instead of psb_X_vector. To be deleted eventually. ! diff --git a/mlprec/impl/mld_dmlprec_aply.f90 b/mlprec/impl/mld_dmlprec_aply.f90 index 94d0bec5..ca5264f9 100644 --- a/mlprec/impl/mld_dmlprec_aply.f90 +++ b/mlprec/impl/mld_dmlprec_aply.f90 @@ -847,7 +847,7 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& - & wv => p%precv(level)%wrk%wv) + & wv => p%precv(level)%wrk%wv(8:)) if (level == nlev) then ! ! Apply smoother @@ -1017,7 +1017,7 @@ contains !Other variables type(psb_d_vect_type) :: v, w, rhs, v1, x - type(psb_d_vect_type), dimension(0:1) :: d + type(psb_d_vect_type) :: d0, d1 real(psb_dpk_) :: delta_old, rhs_norm, alpha, tau, tau1, tau2, tau3, tau4, beta real(psb_dpk_) :: l2_norm, delta, rtol=0.25, delta0, tnrm @@ -1025,37 +1025,50 @@ contains integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx character(len=20) :: name = 'innerit_k_cycle' + + if (size(p%precv(level)%wrk%wv)<7) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid wv size') + goto 9999 + end if + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& - & wv => p%precv(level)%wrk%wv) + & v => p%precv(level)%wrk%wv(1), & + & w => p%precv(level)%wrk%wv(2),& + & rhs => p%precv(level)%wrk%wv(3))!, & +!!$ & v1 => p%precv(level)%wrk%wv(4), & +!!$ & x => p%precv(level)%wrk%wv(5), & +!!$ & d0 => p%precv(level)%wrk%wv(1), & +!!$ & d1 => p%precv(level)%wrk%wv(2)) !Assemble rhs, w, v, v1, x - call psb_geasb(rhs,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) - call psb_geasb(w,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) - call psb_geasb(v,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) +!!$ call psb_geasb(rhs,& +!!$ & base_desc,info,& +!!$ & scratch=.true.,mold=vx2l%v) +!!$ call psb_geasb(w,& +!!$ & base_desc,info,& +!!$ & scratch=.true.,mold=vx2l%v) +!!$ call psb_geasb(v,& +!!$ & base_desc,info,& +!!$ & scratch=.true.,mold=vx2l%v) call psb_geasb(v1,& & base_desc,info,& & scratch=.true.,mold=vx2l%v) call psb_geasb(x,& & base_desc,info,& & scratch=.true.,mold=vx2l%v) - !Assemble d(0) and d(1) - call psb_geasb(d(0),& + !Assemble d0 and d1 + call psb_geasb(d0,& & base_desc,info,& & scratch=.true.,mold=vy2l%v) - call psb_geasb(d(1),& + call psb_geasb(d1,& & base_desc,info,& & scratch=.true.,mold=vy2l%v) - call x%zero() ! rhs=vx2l and w=rhs @@ -1080,9 +1093,9 @@ contains idx=0 call inner_ml_aply(level,p,trans,work,info) - call psb_geaxpby(done,vy2l,dzero,d(idx),base_desc,info) + call psb_geaxpby(done,vy2l,dzero,d0,base_desc,info) - call psb_spmm(done,base_a,d(idx),dzero,v,base_desc,info) + call psb_spmm(done,base_a,d0,dzero,v,base_desc,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') @@ -1091,8 +1104,8 @@ contains !FCG if (psb_toupper(trim(innersolv)) == 'FCG') then - delta_old = psb_gedot(d(idx), w, base_desc, info) - tau = psb_gedot(d(idx), v, base_desc, info) + delta_old = psb_gedot(d0, w, base_desc, info) + tau = psb_gedot(d0, v, base_desc, info) !GCR else if (psb_toupper(trim(innersolv)) == 'GCR') then delta_old = psb_gedot(v, w, base_desc, info) @@ -1112,7 +1125,7 @@ contains if (l2_norm <= rtol*delta0) then !Update solution x - call psb_geaxpby(alpha, d(idx), done, x, base_desc, info) + call psb_geaxpby(alpha, d0, done, x, base_desc, info) else iter = iter + 1 idx=mod(iter,2) @@ -1120,11 +1133,11 @@ contains !Apply preconditioner call psb_geaxpby(done,w,dzero,vx2l,base_desc,info) call inner_ml_aply(level,p,trans,work,info) - call psb_geaxpby(done,vy2l,dzero,d(idx),base_desc,info) + call psb_geaxpby(done,vy2l,dzero,d1,base_desc,info) !Sparse matrix vector product - call psb_spmm(done,base_a,d(idx),dzero,v1,base_desc,info) + call psb_spmm(done,base_a,d1,dzero,v1,base_desc,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') @@ -1133,9 +1146,9 @@ contains !tau1, tau2, tau3, tau4 if (psb_toupper(trim(innersolv)) == 'FCG') then - tau1= psb_gedot(d(idx), v, base_desc, info) - tau2= psb_gedot(d(idx), v1, base_desc, info) - tau3= psb_gedot(d(idx), w, base_desc, info) + tau1= psb_gedot(d1, v, base_desc, info) + tau2= psb_gedot(d1, v1, base_desc, info) + tau3= psb_gedot(d1, w, base_desc, info) tau4= tau2 - (tau1*tau1)/tau else if (psb_toupper(trim(innersolv)) == 'GCR') then tau1= psb_gedot(v1, v, base_desc, info) @@ -1150,19 +1163,20 @@ contains !Update solution alpha=alpha-(tau1*tau3)/(tau*tau4) - call psb_geaxpby(alpha,d(idx - 1),done,x,base_desc,info) + call psb_geaxpby(alpha,d0,done,x,base_desc,info) alpha=tau3/tau4 - call psb_geaxpby(alpha,d(idx),done,x,base_desc,info) + call psb_geaxpby(alpha,d1,done,x,base_desc,info) endif call psb_geaxpby(done,x,dzero,vy2l,base_desc,info) !Free vectors - call psb_gefree(v, base_desc, info) +!!$ call psb_gefree(v, base_desc, info) +!!$ call psb_gefree(w, base_desc, info) +!!$ call psb_gefree(rhs, base_desc, info) call psb_gefree(v1, base_desc, info) - call psb_gefree(w, base_desc, info) call psb_gefree(x, base_desc, info) - call psb_gefree(d(0), base_desc, info) - call psb_gefree(d(1), base_desc, info) + call psb_gefree(d0, base_desc, info) + call psb_gefree(d1, base_desc, info) end associate 9999 continue call psb_erractionrestore(err_act) @@ -1176,9 +1190,6 @@ contains end subroutine mld_dmlprec_aply_vect - - - ! ! Old routine for arrays instead of psb_X_vector. To be deleted eventually. ! diff --git a/mlprec/impl/mld_smlprec_aply.f90 b/mlprec/impl/mld_smlprec_aply.f90 index ebfcc34d..8fe44994 100644 --- a/mlprec/impl/mld_smlprec_aply.f90 +++ b/mlprec/impl/mld_smlprec_aply.f90 @@ -847,7 +847,7 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& - & wv => p%precv(level)%wrk%wv) + & wv => p%precv(level)%wrk%wv(8:)) if (level == nlev) then ! ! Apply smoother @@ -1017,7 +1017,7 @@ contains !Other variables type(psb_s_vect_type) :: v, w, rhs, v1, x - type(psb_s_vect_type), dimension(0:1) :: d + type(psb_s_vect_type) :: d0, d1 real(psb_spk_) :: delta_old, rhs_norm, alpha, tau, tau1, tau2, tau3, tau4, beta real(psb_spk_) :: l2_norm, delta, rtol=0.25, delta0, tnrm @@ -1025,37 +1025,50 @@ contains integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx character(len=20) :: name = 'innerit_k_cycle' + + if (size(p%precv(level)%wrk%wv)<7) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid wv size') + goto 9999 + end if + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& - & wv => p%precv(level)%wrk%wv) + & v => p%precv(level)%wrk%wv(1), & + & w => p%precv(level)%wrk%wv(2),& + & rhs => p%precv(level)%wrk%wv(3))!, & +!!$ & v1 => p%precv(level)%wrk%wv(4), & +!!$ & x => p%precv(level)%wrk%wv(5), & +!!$ & d0 => p%precv(level)%wrk%wv(1), & +!!$ & d1 => p%precv(level)%wrk%wv(2)) !Assemble rhs, w, v, v1, x - call psb_geasb(rhs,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) - call psb_geasb(w,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) - call psb_geasb(v,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) +!!$ call psb_geasb(rhs,& +!!$ & base_desc,info,& +!!$ & scratch=.true.,mold=vx2l%v) +!!$ call psb_geasb(w,& +!!$ & base_desc,info,& +!!$ & scratch=.true.,mold=vx2l%v) +!!$ call psb_geasb(v,& +!!$ & base_desc,info,& +!!$ & scratch=.true.,mold=vx2l%v) call psb_geasb(v1,& & base_desc,info,& & scratch=.true.,mold=vx2l%v) call psb_geasb(x,& & base_desc,info,& & scratch=.true.,mold=vx2l%v) - !Assemble d(0) and d(1) - call psb_geasb(d(0),& + !Assemble d0 and d1 + call psb_geasb(d0,& & base_desc,info,& & scratch=.true.,mold=vy2l%v) - call psb_geasb(d(1),& + call psb_geasb(d1,& & base_desc,info,& & scratch=.true.,mold=vy2l%v) - call x%zero() ! rhs=vx2l and w=rhs @@ -1080,9 +1093,9 @@ contains idx=0 call inner_ml_aply(level,p,trans,work,info) - call psb_geaxpby(sone,vy2l,szero,d(idx),base_desc,info) + call psb_geaxpby(sone,vy2l,szero,d0,base_desc,info) - call psb_spmm(sone,base_a,d(idx),szero,v,base_desc,info) + call psb_spmm(sone,base_a,d0,szero,v,base_desc,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') @@ -1091,8 +1104,8 @@ contains !FCG if (psb_toupper(trim(innersolv)) == 'FCG') then - delta_old = psb_gedot(d(idx), w, base_desc, info) - tau = psb_gedot(d(idx), v, base_desc, info) + delta_old = psb_gedot(d0, w, base_desc, info) + tau = psb_gedot(d0, v, base_desc, info) !GCR else if (psb_toupper(trim(innersolv)) == 'GCR') then delta_old = psb_gedot(v, w, base_desc, info) @@ -1112,7 +1125,7 @@ contains if (l2_norm <= rtol*delta0) then !Update solution x - call psb_geaxpby(alpha, d(idx), sone, x, base_desc, info) + call psb_geaxpby(alpha, d0, sone, x, base_desc, info) else iter = iter + 1 idx=mod(iter,2) @@ -1120,11 +1133,11 @@ contains !Apply preconditioner call psb_geaxpby(sone,w,szero,vx2l,base_desc,info) call inner_ml_aply(level,p,trans,work,info) - call psb_geaxpby(sone,vy2l,szero,d(idx),base_desc,info) + call psb_geaxpby(sone,vy2l,szero,d1,base_desc,info) !Sparse matrix vector product - call psb_spmm(sone,base_a,d(idx),szero,v1,base_desc,info) + call psb_spmm(sone,base_a,d1,szero,v1,base_desc,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') @@ -1133,9 +1146,9 @@ contains !tau1, tau2, tau3, tau4 if (psb_toupper(trim(innersolv)) == 'FCG') then - tau1= psb_gedot(d(idx), v, base_desc, info) - tau2= psb_gedot(d(idx), v1, base_desc, info) - tau3= psb_gedot(d(idx), w, base_desc, info) + tau1= psb_gedot(d1, v, base_desc, info) + tau2= psb_gedot(d1, v1, base_desc, info) + tau3= psb_gedot(d1, w, base_desc, info) tau4= tau2 - (tau1*tau1)/tau else if (psb_toupper(trim(innersolv)) == 'GCR') then tau1= psb_gedot(v1, v, base_desc, info) @@ -1150,19 +1163,20 @@ contains !Update solution alpha=alpha-(tau1*tau3)/(tau*tau4) - call psb_geaxpby(alpha,d(idx - 1),sone,x,base_desc,info) + call psb_geaxpby(alpha,d0,sone,x,base_desc,info) alpha=tau3/tau4 - call psb_geaxpby(alpha,d(idx),sone,x,base_desc,info) + call psb_geaxpby(alpha,d1,sone,x,base_desc,info) endif call psb_geaxpby(sone,x,szero,vy2l,base_desc,info) !Free vectors - call psb_gefree(v, base_desc, info) +!!$ call psb_gefree(v, base_desc, info) +!!$ call psb_gefree(w, base_desc, info) +!!$ call psb_gefree(rhs, base_desc, info) call psb_gefree(v1, base_desc, info) - call psb_gefree(w, base_desc, info) call psb_gefree(x, base_desc, info) - call psb_gefree(d(0), base_desc, info) - call psb_gefree(d(1), base_desc, info) + call psb_gefree(d0, base_desc, info) + call psb_gefree(d1, base_desc, info) end associate 9999 continue call psb_erractionrestore(err_act) @@ -1176,9 +1190,6 @@ contains end subroutine mld_smlprec_aply_vect - - - ! ! Old routine for arrays instead of psb_X_vector. To be deleted eventually. ! diff --git a/mlprec/impl/mld_zmlprec_aply.f90 b/mlprec/impl/mld_zmlprec_aply.f90 index a0d4f51e..59a97788 100644 --- a/mlprec/impl/mld_zmlprec_aply.f90 +++ b/mlprec/impl/mld_zmlprec_aply.f90 @@ -847,7 +847,7 @@ contains associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& - & wv => p%precv(level)%wrk%wv) + & wv => p%precv(level)%wrk%wv(8:)) if (level == nlev) then ! ! Apply smoother @@ -1017,7 +1017,7 @@ contains !Other variables type(psb_z_vect_type) :: v, w, rhs, v1, x - type(psb_z_vect_type), dimension(0:1) :: d + type(psb_z_vect_type) :: d0, d1 complex(psb_dpk_) :: delta_old, rhs_norm, alpha, tau, tau1, tau2, tau3, tau4, beta real(psb_dpk_) :: l2_norm, delta, rtol=0.25, delta0, tnrm @@ -1025,37 +1025,50 @@ contains integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx character(len=20) :: name = 'innerit_k_cycle' + + if (size(p%precv(level)%wrk%wv)<7) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid wv size') + goto 9999 + end if + associate(vx2l => p%precv(level)%wrk%vx2l,vy2l => p%precv(level)%wrk%vy2l,& & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& - & wv => p%precv(level)%wrk%wv) + & v => p%precv(level)%wrk%wv(1), & + & w => p%precv(level)%wrk%wv(2),& + & rhs => p%precv(level)%wrk%wv(3))!, & +!!$ & v1 => p%precv(level)%wrk%wv(4), & +!!$ & x => p%precv(level)%wrk%wv(5), & +!!$ & d0 => p%precv(level)%wrk%wv(1), & +!!$ & d1 => p%precv(level)%wrk%wv(2)) !Assemble rhs, w, v, v1, x - call psb_geasb(rhs,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) - call psb_geasb(w,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) - call psb_geasb(v,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) +!!$ call psb_geasb(rhs,& +!!$ & base_desc,info,& +!!$ & scratch=.true.,mold=vx2l%v) +!!$ call psb_geasb(w,& +!!$ & base_desc,info,& +!!$ & scratch=.true.,mold=vx2l%v) +!!$ call psb_geasb(v,& +!!$ & base_desc,info,& +!!$ & scratch=.true.,mold=vx2l%v) call psb_geasb(v1,& & base_desc,info,& & scratch=.true.,mold=vx2l%v) call psb_geasb(x,& & base_desc,info,& & scratch=.true.,mold=vx2l%v) - !Assemble d(0) and d(1) - call psb_geasb(d(0),& + !Assemble d0 and d1 + call psb_geasb(d0,& & base_desc,info,& & scratch=.true.,mold=vy2l%v) - call psb_geasb(d(1),& + call psb_geasb(d1,& & base_desc,info,& & scratch=.true.,mold=vy2l%v) - call x%zero() ! rhs=vx2l and w=rhs @@ -1080,9 +1093,9 @@ contains idx=0 call inner_ml_aply(level,p,trans,work,info) - call psb_geaxpby(zone,vy2l,zzero,d(idx),base_desc,info) + call psb_geaxpby(zone,vy2l,zzero,d0,base_desc,info) - call psb_spmm(zone,base_a,d(idx),zzero,v,base_desc,info) + call psb_spmm(zone,base_a,d0,zzero,v,base_desc,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') @@ -1091,8 +1104,8 @@ contains !FCG if (psb_toupper(trim(innersolv)) == 'FCG') then - delta_old = psb_gedot(d(idx), w, base_desc, info) - tau = psb_gedot(d(idx), v, base_desc, info) + delta_old = psb_gedot(d0, w, base_desc, info) + tau = psb_gedot(d0, v, base_desc, info) !GCR else if (psb_toupper(trim(innersolv)) == 'GCR') then delta_old = psb_gedot(v, w, base_desc, info) @@ -1112,7 +1125,7 @@ contains if (l2_norm <= rtol*delta0) then !Update solution x - call psb_geaxpby(alpha, d(idx), zone, x, base_desc, info) + call psb_geaxpby(alpha, d0, zone, x, base_desc, info) else iter = iter + 1 idx=mod(iter,2) @@ -1120,11 +1133,11 @@ contains !Apply preconditioner call psb_geaxpby(zone,w,zzero,vx2l,base_desc,info) call inner_ml_aply(level,p,trans,work,info) - call psb_geaxpby(zone,vy2l,zzero,d(idx),base_desc,info) + call psb_geaxpby(zone,vy2l,zzero,d1,base_desc,info) !Sparse matrix vector product - call psb_spmm(zone,base_a,d(idx),zzero,v1,base_desc,info) + call psb_spmm(zone,base_a,d1,zzero,v1,base_desc,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') @@ -1133,9 +1146,9 @@ contains !tau1, tau2, tau3, tau4 if (psb_toupper(trim(innersolv)) == 'FCG') then - tau1= psb_gedot(d(idx), v, base_desc, info) - tau2= psb_gedot(d(idx), v1, base_desc, info) - tau3= psb_gedot(d(idx), w, base_desc, info) + tau1= psb_gedot(d1, v, base_desc, info) + tau2= psb_gedot(d1, v1, base_desc, info) + tau3= psb_gedot(d1, w, base_desc, info) tau4= tau2 - (tau1*tau1)/tau else if (psb_toupper(trim(innersolv)) == 'GCR') then tau1= psb_gedot(v1, v, base_desc, info) @@ -1150,19 +1163,20 @@ contains !Update solution alpha=alpha-(tau1*tau3)/(tau*tau4) - call psb_geaxpby(alpha,d(idx - 1),zone,x,base_desc,info) + call psb_geaxpby(alpha,d0,zone,x,base_desc,info) alpha=tau3/tau4 - call psb_geaxpby(alpha,d(idx),zone,x,base_desc,info) + call psb_geaxpby(alpha,d1,zone,x,base_desc,info) endif call psb_geaxpby(zone,x,zzero,vy2l,base_desc,info) !Free vectors - call psb_gefree(v, base_desc, info) +!!$ call psb_gefree(v, base_desc, info) +!!$ call psb_gefree(w, base_desc, info) +!!$ call psb_gefree(rhs, base_desc, info) call psb_gefree(v1, base_desc, info) - call psb_gefree(w, base_desc, info) call psb_gefree(x, base_desc, info) - call psb_gefree(d(0), base_desc, info) - call psb_gefree(d(1), base_desc, info) + call psb_gefree(d0, base_desc, info) + call psb_gefree(d1, base_desc, info) end associate 9999 continue call psb_erractionrestore(err_act) @@ -1176,9 +1190,6 @@ contains end subroutine mld_zmlprec_aply_vect - - - ! ! Old routine for arrays instead of psb_X_vector. To be deleted eventually. ! diff --git a/mlprec/mld_c_onelev_mod.f90 b/mlprec/mld_c_onelev_mod.f90 index ca80d8e2..3035d30f 100644 --- a/mlprec/mld_c_onelev_mod.f90 +++ b/mlprec/mld_c_onelev_mod.f90 @@ -573,9 +573,10 @@ contains case(mld_kcycle_ml_, mld_kcyclesym_ml_) ! - ! We need 7 in inneritkcycle, but we can reuse vtx + ! We need 7 in inneritkcycle. + ! Can we reuse vtx? ! - val = val + 6 + val = val + 7 case default ! Need a better error signaling ? diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index bd693548..e8223c68 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -573,9 +573,10 @@ contains case(mld_kcycle_ml_, mld_kcyclesym_ml_) ! - ! We need 7 in inneritkcycle, but we can reuse vtx + ! We need 7 in inneritkcycle. + ! Can we reuse vtx? ! - val = val + 6 + val = val + 7 case default ! Need a better error signaling ? diff --git a/mlprec/mld_s_onelev_mod.f90 b/mlprec/mld_s_onelev_mod.f90 index 7a582b6b..85317faa 100644 --- a/mlprec/mld_s_onelev_mod.f90 +++ b/mlprec/mld_s_onelev_mod.f90 @@ -573,9 +573,10 @@ contains case(mld_kcycle_ml_, mld_kcyclesym_ml_) ! - ! We need 7 in inneritkcycle, but we can reuse vtx + ! We need 7 in inneritkcycle. + ! Can we reuse vtx? ! - val = val + 6 + val = val + 7 case default ! Need a better error signaling ? diff --git a/mlprec/mld_z_onelev_mod.f90 b/mlprec/mld_z_onelev_mod.f90 index 589750bb..f6d14102 100644 --- a/mlprec/mld_z_onelev_mod.f90 +++ b/mlprec/mld_z_onelev_mod.f90 @@ -573,9 +573,10 @@ contains case(mld_kcycle_ml_, mld_kcyclesym_ml_) ! - ! We need 7 in inneritkcycle, but we can reuse vtx + ! We need 7 in inneritkcycle. + ! Can we reuse vtx? ! - val = val + 6 + val = val + 7 case default ! Need a better error signaling ? From 63233716c475f63b209145d8d86312bb82d0e241 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 12 Dec 2017 11:02:07 +0000 Subject: [PATCH 14/16] K-Cycle now using work vectors correctly. --- mlprec/impl/mld_cmlprec_aply.f90 | 96 ++++++++------------------------ mlprec/impl/mld_dmlprec_aply.f90 | 96 ++++++++------------------------ mlprec/impl/mld_smlprec_aply.f90 | 96 ++++++++------------------------ mlprec/impl/mld_zmlprec_aply.f90 | 96 ++++++++------------------------ 4 files changed, 92 insertions(+), 292 deletions(-) diff --git a/mlprec/impl/mld_cmlprec_aply.f90 b/mlprec/impl/mld_cmlprec_aply.f90 index f6118c99..050d9916 100644 --- a/mlprec/impl/mld_cmlprec_aply.f90 +++ b/mlprec/impl/mld_cmlprec_aply.f90 @@ -487,9 +487,7 @@ contains & wv => p%precv(level)%wrk%wv) if (allocated(p%precv(level)%sm2a)) then - call psb_geaxpby(cone,& - & vx2l,czero,vy2l,& - & base_desc,info) + call psb_geaxpby(cone,vx2l,czero,vy2l,base_desc,info) sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post) do k=1, sweeps @@ -621,14 +619,12 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & vx2l,czero,vy2l,& - & base_desc, trans,& + & vx2l,czero,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& - & vx2l,czero,vy2l,& - & base_desc, trans,& + & vx2l,czero,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') end if @@ -693,8 +689,7 @@ contains if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then - call psb_geaxpby(cone,vx2l,& - & czero,vty,& + call psb_geaxpby(cone,vx2l, czero,vty,& & base_desc,info) if (info == psb_success_) call psb_spmm(-cone,base_a,& & vy2l,cone,vty,& @@ -730,8 +725,7 @@ contains & czero,vty,& & base_desc,info) if (info == psb_success_) call psb_spmm(-cone,base_a,& - & vy2l,& - & cone,vty,base_desc,info,& + & vy2l, cone,vty,base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -745,14 +739,12 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& - & vty,cone,vy2l,& - & base_desc, trans,& + & vty,cone,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & vty,cone,vy2l,& - & base_desc, trans,& + & vty,cone,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') end if @@ -768,8 +760,7 @@ contains sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & vx2l,czero,vy2l,& - & base_desc, trans,& + & vx2l,czero,vy2l,base_desc, trans,& & sweeps,work,wv,info) else @@ -854,8 +845,7 @@ contains ! sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & vx2l,czero,vy2l,& - & base_desc, trans,& + & vx2l,czero,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') else if (level < nlev) then @@ -863,14 +853,12 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & vx2l,czero,vy2l,& - & base_desc, trans,& + & vx2l,czero,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& - & vx2l,czero,vy2l,& - & base_desc, trans,& + & vx2l,czero,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') end if @@ -890,8 +878,7 @@ contains & base_desc,info) if (info == psb_success_) call psb_spmm(-cone,base_a,& - & vy2l,cone,vty,& - & base_desc,info,work=work,trans=trans) + & vy2l,cone,vty,base_desc,info,work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') @@ -950,8 +937,7 @@ contains ! Compute the residual ! call psb_geaxpby(cone,vx2l,& - & czero,vty,& - & base_desc,info) + & czero,vty,base_desc,info) call psb_spmm(-cone,base_a,vy2l,& & cone,vty,base_desc,info,& & work=work,trans=trans) @@ -966,14 +952,12 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& - & vty,cone,vy2l,& - & base_desc, trans,& + & vty,cone,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & vty,cone,vy2l,& - & base_desc, trans,& + & vty,cone,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') end if @@ -1038,44 +1022,17 @@ contains & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& & v => p%precv(level)%wrk%wv(1), & & w => p%precv(level)%wrk%wv(2),& - & rhs => p%precv(level)%wrk%wv(3))!, & -!!$ & v1 => p%precv(level)%wrk%wv(4), & -!!$ & x => p%precv(level)%wrk%wv(5), & -!!$ & d0 => p%precv(level)%wrk%wv(1), & -!!$ & d1 => p%precv(level)%wrk%wv(2)) - - !Assemble rhs, w, v, v1, x - -!!$ call psb_geasb(rhs,& -!!$ & base_desc,info,& -!!$ & scratch=.true.,mold=vx2l%v) -!!$ call psb_geasb(w,& -!!$ & base_desc,info,& -!!$ & scratch=.true.,mold=vx2l%v) -!!$ call psb_geasb(v,& -!!$ & base_desc,info,& -!!$ & scratch=.true.,mold=vx2l%v) - call psb_geasb(v1,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) - call psb_geasb(x,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) - !Assemble d0 and d1 - call psb_geasb(d0,& - & base_desc,info,& - & scratch=.true.,mold=vy2l%v) - call psb_geasb(d1,& - & base_desc,info,& - & scratch=.true.,mold=vy2l%v) + & rhs => p%precv(level)%wrk%wv(3), & + & v1 => p%precv(level)%wrk%wv(4), & + & x => p%precv(level)%wrk%wv(5), & + & d0 => p%precv(level)%wrk%wv(6), & + & d1 => p%precv(level)%wrk%wv(7)) call x%zero() ! rhs=vx2l and w=rhs - call psb_geaxpby(cone,vx2l,czero,rhs,& - & base_desc,info) - call psb_geaxpby(cone,vx2l,czero,w,& - & base_desc,info) + call psb_geaxpby(cone,vx2l,czero,rhs, base_desc,info) + call psb_geaxpby(cone,vx2l,czero,w, base_desc,info) if (psb_errstatus_fatal()) then nc2l = base_desc%get_local_cols() @@ -1169,15 +1126,8 @@ contains endif call psb_geaxpby(cone,x,czero,vy2l,base_desc,info) - !Free vectors -!!$ call psb_gefree(v, base_desc, info) -!!$ call psb_gefree(w, base_desc, info) -!!$ call psb_gefree(rhs, base_desc, info) - call psb_gefree(v1, base_desc, info) - call psb_gefree(x, base_desc, info) - call psb_gefree(d0, base_desc, info) - call psb_gefree(d1, base_desc, info) end associate + 9999 continue call psb_erractionrestore(err_act) if (err_act.eq.psb_act_abort_) then diff --git a/mlprec/impl/mld_dmlprec_aply.f90 b/mlprec/impl/mld_dmlprec_aply.f90 index ca5264f9..9aab499b 100644 --- a/mlprec/impl/mld_dmlprec_aply.f90 +++ b/mlprec/impl/mld_dmlprec_aply.f90 @@ -487,9 +487,7 @@ contains & wv => p%precv(level)%wrk%wv) if (allocated(p%precv(level)%sm2a)) then - call psb_geaxpby(done,& - & vx2l,dzero,vy2l,& - & base_desc,info) + call psb_geaxpby(done,vx2l,dzero,vy2l,base_desc,info) sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post) do k=1, sweeps @@ -621,14 +619,12 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & vx2l,dzero,vy2l,& - & base_desc, trans,& + & vx2l,dzero,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & vx2l,dzero,vy2l,& - & base_desc, trans,& + & vx2l,dzero,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') end if @@ -693,8 +689,7 @@ contains if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then - call psb_geaxpby(done,vx2l,& - & dzero,vty,& + call psb_geaxpby(done,vx2l, dzero,vty,& & base_desc,info) if (info == psb_success_) call psb_spmm(-done,base_a,& & vy2l,done,vty,& @@ -730,8 +725,7 @@ contains & dzero,vty,& & base_desc,info) if (info == psb_success_) call psb_spmm(-done,base_a,& - & vy2l,& - & done,vty,base_desc,info,& + & vy2l, done,vty,base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -745,14 +739,12 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & vty,done,vy2l,& - & base_desc, trans,& + & vty,done,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & vty,done,vy2l,& - & base_desc, trans,& + & vty,done,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') end if @@ -768,8 +760,7 @@ contains sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & vx2l,dzero,vy2l,& - & base_desc, trans,& + & vx2l,dzero,vy2l,base_desc, trans,& & sweeps,work,wv,info) else @@ -854,8 +845,7 @@ contains ! sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & vx2l,dzero,vy2l,& - & base_desc, trans,& + & vx2l,dzero,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') else if (level < nlev) then @@ -863,14 +853,12 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & vx2l,dzero,vy2l,& - & base_desc, trans,& + & vx2l,dzero,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & vx2l,dzero,vy2l,& - & base_desc, trans,& + & vx2l,dzero,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') end if @@ -890,8 +878,7 @@ contains & base_desc,info) if (info == psb_success_) call psb_spmm(-done,base_a,& - & vy2l,done,vty,& - & base_desc,info,work=work,trans=trans) + & vy2l,done,vty,base_desc,info,work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') @@ -950,8 +937,7 @@ contains ! Compute the residual ! call psb_geaxpby(done,vx2l,& - & dzero,vty,& - & base_desc,info) + & dzero,vty,base_desc,info) call psb_spmm(-done,base_a,vy2l,& & done,vty,base_desc,info,& & work=work,trans=trans) @@ -966,14 +952,12 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & vty,done,vy2l,& - & base_desc, trans,& + & vty,done,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & vty,done,vy2l,& - & base_desc, trans,& + & vty,done,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') end if @@ -1038,44 +1022,17 @@ contains & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& & v => p%precv(level)%wrk%wv(1), & & w => p%precv(level)%wrk%wv(2),& - & rhs => p%precv(level)%wrk%wv(3))!, & -!!$ & v1 => p%precv(level)%wrk%wv(4), & -!!$ & x => p%precv(level)%wrk%wv(5), & -!!$ & d0 => p%precv(level)%wrk%wv(1), & -!!$ & d1 => p%precv(level)%wrk%wv(2)) - - !Assemble rhs, w, v, v1, x - -!!$ call psb_geasb(rhs,& -!!$ & base_desc,info,& -!!$ & scratch=.true.,mold=vx2l%v) -!!$ call psb_geasb(w,& -!!$ & base_desc,info,& -!!$ & scratch=.true.,mold=vx2l%v) -!!$ call psb_geasb(v,& -!!$ & base_desc,info,& -!!$ & scratch=.true.,mold=vx2l%v) - call psb_geasb(v1,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) - call psb_geasb(x,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) - !Assemble d0 and d1 - call psb_geasb(d0,& - & base_desc,info,& - & scratch=.true.,mold=vy2l%v) - call psb_geasb(d1,& - & base_desc,info,& - & scratch=.true.,mold=vy2l%v) + & rhs => p%precv(level)%wrk%wv(3), & + & v1 => p%precv(level)%wrk%wv(4), & + & x => p%precv(level)%wrk%wv(5), & + & d0 => p%precv(level)%wrk%wv(6), & + & d1 => p%precv(level)%wrk%wv(7)) call x%zero() ! rhs=vx2l and w=rhs - call psb_geaxpby(done,vx2l,dzero,rhs,& - & base_desc,info) - call psb_geaxpby(done,vx2l,dzero,w,& - & base_desc,info) + call psb_geaxpby(done,vx2l,dzero,rhs, base_desc,info) + call psb_geaxpby(done,vx2l,dzero,w, base_desc,info) if (psb_errstatus_fatal()) then nc2l = base_desc%get_local_cols() @@ -1169,15 +1126,8 @@ contains endif call psb_geaxpby(done,x,dzero,vy2l,base_desc,info) - !Free vectors -!!$ call psb_gefree(v, base_desc, info) -!!$ call psb_gefree(w, base_desc, info) -!!$ call psb_gefree(rhs, base_desc, info) - call psb_gefree(v1, base_desc, info) - call psb_gefree(x, base_desc, info) - call psb_gefree(d0, base_desc, info) - call psb_gefree(d1, base_desc, info) end associate + 9999 continue call psb_erractionrestore(err_act) if (err_act.eq.psb_act_abort_) then diff --git a/mlprec/impl/mld_smlprec_aply.f90 b/mlprec/impl/mld_smlprec_aply.f90 index 8fe44994..749c140a 100644 --- a/mlprec/impl/mld_smlprec_aply.f90 +++ b/mlprec/impl/mld_smlprec_aply.f90 @@ -487,9 +487,7 @@ contains & wv => p%precv(level)%wrk%wv) if (allocated(p%precv(level)%sm2a)) then - call psb_geaxpby(sone,& - & vx2l,szero,vy2l,& - & base_desc,info) + call psb_geaxpby(sone,vx2l,szero,vy2l,base_desc,info) sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post) do k=1, sweeps @@ -621,14 +619,12 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & vx2l,szero,vy2l,& - & base_desc, trans,& + & vx2l,szero,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& - & vx2l,szero,vy2l,& - & base_desc, trans,& + & vx2l,szero,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') end if @@ -693,8 +689,7 @@ contains if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then - call psb_geaxpby(sone,vx2l,& - & szero,vty,& + call psb_geaxpby(sone,vx2l, szero,vty,& & base_desc,info) if (info == psb_success_) call psb_spmm(-sone,base_a,& & vy2l,sone,vty,& @@ -730,8 +725,7 @@ contains & szero,vty,& & base_desc,info) if (info == psb_success_) call psb_spmm(-sone,base_a,& - & vy2l,& - & sone,vty,base_desc,info,& + & vy2l, sone,vty,base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -745,14 +739,12 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& - & vty,sone,vy2l,& - & base_desc, trans,& + & vty,sone,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & vty,sone,vy2l,& - & base_desc, trans,& + & vty,sone,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') end if @@ -768,8 +760,7 @@ contains sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & vx2l,szero,vy2l,& - & base_desc, trans,& + & vx2l,szero,vy2l,base_desc, trans,& & sweeps,work,wv,info) else @@ -854,8 +845,7 @@ contains ! sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & vx2l,szero,vy2l,& - & base_desc, trans,& + & vx2l,szero,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') else if (level < nlev) then @@ -863,14 +853,12 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & vx2l,szero,vy2l,& - & base_desc, trans,& + & vx2l,szero,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& - & vx2l,szero,vy2l,& - & base_desc, trans,& + & vx2l,szero,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') end if @@ -890,8 +878,7 @@ contains & base_desc,info) if (info == psb_success_) call psb_spmm(-sone,base_a,& - & vy2l,sone,vty,& - & base_desc,info,work=work,trans=trans) + & vy2l,sone,vty,base_desc,info,work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') @@ -950,8 +937,7 @@ contains ! Compute the residual ! call psb_geaxpby(sone,vx2l,& - & szero,vty,& - & base_desc,info) + & szero,vty,base_desc,info) call psb_spmm(-sone,base_a,vy2l,& & sone,vty,base_desc,info,& & work=work,trans=trans) @@ -966,14 +952,12 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& - & vty,sone,vy2l,& - & base_desc, trans,& + & vty,sone,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & vty,sone,vy2l,& - & base_desc, trans,& + & vty,sone,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') end if @@ -1038,44 +1022,17 @@ contains & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& & v => p%precv(level)%wrk%wv(1), & & w => p%precv(level)%wrk%wv(2),& - & rhs => p%precv(level)%wrk%wv(3))!, & -!!$ & v1 => p%precv(level)%wrk%wv(4), & -!!$ & x => p%precv(level)%wrk%wv(5), & -!!$ & d0 => p%precv(level)%wrk%wv(1), & -!!$ & d1 => p%precv(level)%wrk%wv(2)) - - !Assemble rhs, w, v, v1, x - -!!$ call psb_geasb(rhs,& -!!$ & base_desc,info,& -!!$ & scratch=.true.,mold=vx2l%v) -!!$ call psb_geasb(w,& -!!$ & base_desc,info,& -!!$ & scratch=.true.,mold=vx2l%v) -!!$ call psb_geasb(v,& -!!$ & base_desc,info,& -!!$ & scratch=.true.,mold=vx2l%v) - call psb_geasb(v1,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) - call psb_geasb(x,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) - !Assemble d0 and d1 - call psb_geasb(d0,& - & base_desc,info,& - & scratch=.true.,mold=vy2l%v) - call psb_geasb(d1,& - & base_desc,info,& - & scratch=.true.,mold=vy2l%v) + & rhs => p%precv(level)%wrk%wv(3), & + & v1 => p%precv(level)%wrk%wv(4), & + & x => p%precv(level)%wrk%wv(5), & + & d0 => p%precv(level)%wrk%wv(6), & + & d1 => p%precv(level)%wrk%wv(7)) call x%zero() ! rhs=vx2l and w=rhs - call psb_geaxpby(sone,vx2l,szero,rhs,& - & base_desc,info) - call psb_geaxpby(sone,vx2l,szero,w,& - & base_desc,info) + call psb_geaxpby(sone,vx2l,szero,rhs, base_desc,info) + call psb_geaxpby(sone,vx2l,szero,w, base_desc,info) if (psb_errstatus_fatal()) then nc2l = base_desc%get_local_cols() @@ -1169,15 +1126,8 @@ contains endif call psb_geaxpby(sone,x,szero,vy2l,base_desc,info) - !Free vectors -!!$ call psb_gefree(v, base_desc, info) -!!$ call psb_gefree(w, base_desc, info) -!!$ call psb_gefree(rhs, base_desc, info) - call psb_gefree(v1, base_desc, info) - call psb_gefree(x, base_desc, info) - call psb_gefree(d0, base_desc, info) - call psb_gefree(d1, base_desc, info) end associate + 9999 continue call psb_erractionrestore(err_act) if (err_act.eq.psb_act_abort_) then diff --git a/mlprec/impl/mld_zmlprec_aply.f90 b/mlprec/impl/mld_zmlprec_aply.f90 index 59a97788..c6903bd4 100644 --- a/mlprec/impl/mld_zmlprec_aply.f90 +++ b/mlprec/impl/mld_zmlprec_aply.f90 @@ -487,9 +487,7 @@ contains & wv => p%precv(level)%wrk%wv) if (allocated(p%precv(level)%sm2a)) then - call psb_geaxpby(zone,& - & vx2l,zzero,vy2l,& - & base_desc,info) + call psb_geaxpby(zone,vx2l,zzero,vy2l,base_desc,info) sweeps = max(p%precv(level)%parms%sweeps_pre,p%precv(level)%parms%sweeps_post) do k=1, sweeps @@ -621,14 +619,12 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & vx2l,zzero,vy2l,& - & base_desc, trans,& + & vx2l,zzero,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& - & vx2l,zzero,vy2l,& - & base_desc, trans,& + & vx2l,zzero,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') end if @@ -693,8 +689,7 @@ contains if (p%precv(level)%parms%ml_cycle == mld_wcycle_ml_) then - call psb_geaxpby(zone,vx2l,& - & zzero,vty,& + call psb_geaxpby(zone,vx2l, zzero,vty,& & base_desc,info) if (info == psb_success_) call psb_spmm(-zone,base_a,& & vy2l,zone,vty,& @@ -730,8 +725,7 @@ contains & zzero,vty,& & base_desc,info) if (info == psb_success_) call psb_spmm(-zone,base_a,& - & vy2l,& - & zone,vty,base_desc,info,& + & vy2l, zone,vty,base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -745,14 +739,12 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& - & vty,zone,vy2l,& - & base_desc, trans,& + & vty,zone,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & vty,zone,vy2l,& - & base_desc, trans,& + & vty,zone,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') end if @@ -768,8 +760,7 @@ contains sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & vx2l,zzero,vy2l,& - & base_desc, trans,& + & vx2l,zzero,vy2l,base_desc, trans,& & sweeps,work,wv,info) else @@ -854,8 +845,7 @@ contains ! sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & vx2l,zzero,vy2l,& - & base_desc, trans,& + & vx2l,zzero,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') else if (level < nlev) then @@ -863,14 +853,12 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & vx2l,zzero,vy2l,& - & base_desc, trans,& + & vx2l,zzero,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& - & vx2l,zzero,vy2l,& - & base_desc, trans,& + & vx2l,zzero,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') end if @@ -890,8 +878,7 @@ contains & base_desc,info) if (info == psb_success_) call psb_spmm(-zone,base_a,& - & vy2l,zone,vty,& - & base_desc,info,work=work,trans=trans) + & vy2l,zone,vty,base_desc,info,work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during residue') @@ -950,8 +937,7 @@ contains ! Compute the residual ! call psb_geaxpby(zone,vx2l,& - & zzero,vty,& - & base_desc,info) + & zzero,vty,base_desc,info) call psb_spmm(-zone,base_a,vy2l,& & zone,vty,base_desc,info,& & work=work,trans=trans) @@ -966,14 +952,12 @@ contains if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& - & vty,zone,vy2l,& - & base_desc, trans,& + & vty,zone,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & vty,zone,vy2l,& - & base_desc, trans,& + & vty,zone,vy2l,base_desc, trans,& & sweeps,work,wv,info,init='Z') end if @@ -1038,44 +1022,17 @@ contains & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& & v => p%precv(level)%wrk%wv(1), & & w => p%precv(level)%wrk%wv(2),& - & rhs => p%precv(level)%wrk%wv(3))!, & -!!$ & v1 => p%precv(level)%wrk%wv(4), & -!!$ & x => p%precv(level)%wrk%wv(5), & -!!$ & d0 => p%precv(level)%wrk%wv(1), & -!!$ & d1 => p%precv(level)%wrk%wv(2)) - - !Assemble rhs, w, v, v1, x - -!!$ call psb_geasb(rhs,& -!!$ & base_desc,info,& -!!$ & scratch=.true.,mold=vx2l%v) -!!$ call psb_geasb(w,& -!!$ & base_desc,info,& -!!$ & scratch=.true.,mold=vx2l%v) -!!$ call psb_geasb(v,& -!!$ & base_desc,info,& -!!$ & scratch=.true.,mold=vx2l%v) - call psb_geasb(v1,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) - call psb_geasb(x,& - & base_desc,info,& - & scratch=.true.,mold=vx2l%v) - !Assemble d0 and d1 - call psb_geasb(d0,& - & base_desc,info,& - & scratch=.true.,mold=vy2l%v) - call psb_geasb(d1,& - & base_desc,info,& - & scratch=.true.,mold=vy2l%v) + & rhs => p%precv(level)%wrk%wv(3), & + & v1 => p%precv(level)%wrk%wv(4), & + & x => p%precv(level)%wrk%wv(5), & + & d0 => p%precv(level)%wrk%wv(6), & + & d1 => p%precv(level)%wrk%wv(7)) call x%zero() ! rhs=vx2l and w=rhs - call psb_geaxpby(zone,vx2l,zzero,rhs,& - & base_desc,info) - call psb_geaxpby(zone,vx2l,zzero,w,& - & base_desc,info) + call psb_geaxpby(zone,vx2l,zzero,rhs, base_desc,info) + call psb_geaxpby(zone,vx2l,zzero,w, base_desc,info) if (psb_errstatus_fatal()) then nc2l = base_desc%get_local_cols() @@ -1169,15 +1126,8 @@ contains endif call psb_geaxpby(zone,x,zzero,vy2l,base_desc,info) - !Free vectors -!!$ call psb_gefree(v, base_desc, info) -!!$ call psb_gefree(w, base_desc, info) -!!$ call psb_gefree(rhs, base_desc, info) - call psb_gefree(v1, base_desc, info) - call psb_gefree(x, base_desc, info) - call psb_gefree(d0, base_desc, info) - call psb_gefree(d1, base_desc, info) end associate + 9999 continue call psb_erractionrestore(err_act) if (err_act.eq.psb_act_abort_) then From 54d1478e2141cdf014eeaed82cf7e5e8ae353752 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 12 Dec 2017 11:27:18 +0000 Subject: [PATCH 15/16] Added use of WV in solve apply_vect --- .../solver/mld_c_bwgs_solver_apply_vect.f90 | 118 +++++++++--------- .../solver/mld_c_gs_solver_apply_vect.f90 | 118 +++++++++--------- .../solver/mld_c_ilu_solver_apply_vect.f90 | 70 ++++++----- .../solver/mld_d_bwgs_solver_apply_vect.f90 | 118 +++++++++--------- .../solver/mld_d_gs_solver_apply_vect.f90 | 118 +++++++++--------- .../solver/mld_d_ilu_solver_apply_vect.f90 | 70 ++++++----- .../solver/mld_s_bwgs_solver_apply_vect.f90 | 118 +++++++++--------- .../solver/mld_s_gs_solver_apply_vect.f90 | 118 +++++++++--------- .../solver/mld_s_ilu_solver_apply_vect.f90 | 70 ++++++----- .../solver/mld_z_bwgs_solver_apply_vect.f90 | 118 +++++++++--------- .../solver/mld_z_gs_solver_apply_vect.f90 | 118 +++++++++--------- .../solver/mld_z_ilu_solver_apply_vect.f90 | 70 ++++++----- 12 files changed, 652 insertions(+), 572 deletions(-) diff --git a/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 index 78e73b9c..db152bad 100644 --- a/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 @@ -54,7 +54,6 @@ subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& type(psb_c_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, itx - type(psb_c_vect_type) :: tw, xit complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) complex(psb_spk_), allocatable :: temp(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -121,69 +120,76 @@ subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) - select case (init_) - case('Z') - call xit%zero() - case('Y') - call psb_geaxpby(cone,y,czero,xit,desc_data,info) - case('U') - if (.not.present(initu)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='missing initu to smoother_apply') - goto 9999 - end if - call psb_geaxpby(cone,initu,czero,xit,desc_data,info) - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong init to smoother_apply') + if (size(wv) < 2) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid wv size') goto 9999 - end select - - select case(trans_) - case('N') - if (sv%eps <=szero) then - ! - ! Fixed number of iterations - ! - ! - do itx=1,sv%sweeps - call psb_geaxpby(cone,x,czero,tw,desc_data,info) - ! Update with L. The off-diagonal block is taken care - ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-cone,sv%l,xit,cone,tw,desc_data,info,doswap=.false.) - call psb_spsm(cone,sv%u,tw,czero,xit,desc_data,info) - end do - - call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + end if - else - ! - ! Iterations to convergence, not implemented right now. - ! - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + associate(tw => wv(1), xit => wv(2)) + + select case (init_) + case('Z') + call xit%zero() + case('Y') + call psb_geaxpby(cone,y,czero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(cone,initu,czero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') goto 9999 - - end if - - case default + end select + + select case(trans_) + case('N') + if (sv%eps <=szero) then + ! + ! Fixed number of iterations + ! + ! + do itx=1,sv%sweeps + call psb_geaxpby(cone,x,czero,tw,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-cone,sv%l,xit,cone,tw,desc_data,info,doswap=.false.) + call psb_spsm(cone,sv%u,tw,czero,xit,desc_data,info) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if + + case default info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='Invalid TRANS in GS subsolve') - goto 9999 - end select + & a_err='Invalid TRANS in GS subsolve') + goto 9999 + end select - if (info /= psb_success_) then + if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in subsolve') - goto 9999 - endif - call tw%free(info) - call xit%free(info) + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + end associate + if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then else diff --git a/mlprec/impl/solver/mld_c_gs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_gs_solver_apply_vect.f90 index aeba1ae5..608ffc2c 100644 --- a/mlprec/impl/solver/mld_c_gs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_c_gs_solver_apply_vect.f90 @@ -54,7 +54,6 @@ subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& type(psb_c_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, itx - type(psb_c_vect_type) :: tw, xit complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) complex(psb_spk_), allocatable :: temp(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -121,69 +120,76 @@ subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) - select case (init_) - case('Z') - call xit%zero() - case('Y') - call psb_geaxpby(cone,y,czero,xit,desc_data,info) - case('U') - if (.not.present(initu)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='missing initu to smoother_apply') - goto 9999 - end if - call psb_geaxpby(cone,initu,czero,xit,desc_data,info) - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong init to smoother_apply') + if (size(wv) < 2) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid wv size') goto 9999 - end select - - select case(trans_) - case('N') - if (sv%eps <=szero) then - ! - ! Fixed number of iterations - ! - ! - do itx=1,sv%sweeps - call psb_geaxpby(cone,x,czero,tw,desc_data,info) - ! Update with U. The off-diagonal block is taken care - ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-cone,sv%u,xit,cone,tw,desc_data,info,doswap=.false.) - call psb_spsm(cone,sv%l,tw,czero,xit,desc_data,info) - end do - - call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + end if - else - ! - ! Iterations to convergence, not implemented right now. - ! - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + associate(tw => wv(1), xit => wv(2)) + + select case (init_) + case('Z') + call xit%zero() + case('Y') + call psb_geaxpby(cone,y,czero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(cone,initu,czero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') goto 9999 - - end if - - case default + end select + + select case(trans_) + case('N') + if (sv%eps <=szero) then + ! + ! Fixed number of iterations + ! + ! + do itx=1,sv%sweeps + call psb_geaxpby(cone,x,czero,tw,desc_data,info) + ! Update with U. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-cone,sv%u,xit,cone,tw,desc_data,info,doswap=.false.) + call psb_spsm(cone,sv%l,tw,czero,xit,desc_data,info) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if + + case default info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='Invalid TRANS in GS subsolve') - goto 9999 - end select + & a_err='Invalid TRANS in GS subsolve') + goto 9999 + end select - if (info /= psb_success_) then + if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in subsolve') - goto 9999 - endif - call tw%free(info) - call xit%free(info) + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + end associate + if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then else diff --git a/mlprec/impl/solver/mld_c_ilu_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_ilu_solver_apply_vect.f90 index 953fd757..dce10a84 100644 --- a/mlprec/impl/solver/mld_c_ilu_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_c_ilu_solver_apply_vect.f90 @@ -125,48 +125,56 @@ subroutine mld_c_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(tw1,desc_data,info,mold=x%v,scratch=.true.) - select case(trans_) - case('N') - call psb_spsm(cone,sv%l,x,czero,tw,desc_data,info,& - & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) + if (size(wv) < 2) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid wv size') + goto 9999 + end if - if (info == psb_success_) call psb_spsm(alpha,sv%u,tw,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) + + associate(tw => wv(1), tw1 => wv(2)) - case('T') - call psb_spsm(cone,sv%u,x,czero,tw,desc_data,info,& - & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) - if (info == psb_success_) call psb_spsm(alpha,sv%l,tw,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) + select case(trans_) + case('N') + call psb_spsm(cone,sv%l,x,czero,tw,desc_data,info,& + & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) - case('C') + if (info == psb_success_) call psb_spsm(alpha,sv%u,tw,beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) - call psb_spsm(cone,sv%u,x,czero,tw,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) + case('T') + call psb_spsm(cone,sv%u,x,czero,tw,desc_data,info,& + & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) + if (info == psb_success_) call psb_spsm(alpha,sv%l,tw,beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) - call tw1%mlt(cone,sv%dv,tw,czero,info,conjgx=trans_) + case('C') - if (info == psb_success_) call psb_spsm(alpha,sv%l,tw1,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) + call psb_spsm(cone,sv%u,x,czero,tw,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid TRANS in ILU subsolve') - goto 9999 - end select + call tw1%mlt(cone,sv%dv,tw,czero,info,conjgx=trans_) + if (info == psb_success_) call psb_spsm(alpha,sv%l,tw1,beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) - if (info /= psb_success_) then + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid TRANS in ILU subsolve') + goto 9999 + end select - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in subsolve') - goto 9999 - endif - call tw%free(info) - call tw1%free(info) + + if (info /= psb_success_) then + + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + end associate + if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then else diff --git a/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 index 23dfe512..1b26cfa1 100644 --- a/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 @@ -54,7 +54,6 @@ subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& type(psb_d_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, itx - type(psb_d_vect_type) :: tw, xit real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) real(psb_dpk_), allocatable :: temp(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -121,69 +120,76 @@ subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) - select case (init_) - case('Z') - call xit%zero() - case('Y') - call psb_geaxpby(done,y,dzero,xit,desc_data,info) - case('U') - if (.not.present(initu)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='missing initu to smoother_apply') - goto 9999 - end if - call psb_geaxpby(done,initu,dzero,xit,desc_data,info) - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong init to smoother_apply') + if (size(wv) < 2) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid wv size') goto 9999 - end select - - select case(trans_) - case('N') - if (sv%eps <=dzero) then - ! - ! Fixed number of iterations - ! - ! - do itx=1,sv%sweeps - call psb_geaxpby(done,x,dzero,tw,desc_data,info) - ! Update with L. The off-diagonal block is taken care - ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-done,sv%l,xit,done,tw,desc_data,info,doswap=.false.) - call psb_spsm(done,sv%u,tw,dzero,xit,desc_data,info) - end do - - call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + end if - else - ! - ! Iterations to convergence, not implemented right now. - ! - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + associate(tw => wv(1), xit => wv(2)) + + select case (init_) + case('Z') + call xit%zero() + case('Y') + call psb_geaxpby(done,y,dzero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(done,initu,dzero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') goto 9999 - - end if - - case default + end select + + select case(trans_) + case('N') + if (sv%eps <=dzero) then + ! + ! Fixed number of iterations + ! + ! + do itx=1,sv%sweeps + call psb_geaxpby(done,x,dzero,tw,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-done,sv%l,xit,done,tw,desc_data,info,doswap=.false.) + call psb_spsm(done,sv%u,tw,dzero,xit,desc_data,info) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if + + case default info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='Invalid TRANS in GS subsolve') - goto 9999 - end select + & a_err='Invalid TRANS in GS subsolve') + goto 9999 + end select - if (info /= psb_success_) then + if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in subsolve') - goto 9999 - endif - call tw%free(info) - call xit%free(info) + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + end associate + if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then else diff --git a/mlprec/impl/solver/mld_d_gs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_gs_solver_apply_vect.f90 index b03cb55d..5339249b 100644 --- a/mlprec/impl/solver/mld_d_gs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_d_gs_solver_apply_vect.f90 @@ -54,7 +54,6 @@ subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& type(psb_d_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, itx - type(psb_d_vect_type) :: tw, xit real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) real(psb_dpk_), allocatable :: temp(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -121,69 +120,76 @@ subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) - select case (init_) - case('Z') - call xit%zero() - case('Y') - call psb_geaxpby(done,y,dzero,xit,desc_data,info) - case('U') - if (.not.present(initu)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='missing initu to smoother_apply') - goto 9999 - end if - call psb_geaxpby(done,initu,dzero,xit,desc_data,info) - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong init to smoother_apply') + if (size(wv) < 2) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid wv size') goto 9999 - end select - - select case(trans_) - case('N') - if (sv%eps <=dzero) then - ! - ! Fixed number of iterations - ! - ! - do itx=1,sv%sweeps - call psb_geaxpby(done,x,dzero,tw,desc_data,info) - ! Update with U. The off-diagonal block is taken care - ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-done,sv%u,xit,done,tw,desc_data,info,doswap=.false.) - call psb_spsm(done,sv%l,tw,dzero,xit,desc_data,info) - end do - - call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + end if - else - ! - ! Iterations to convergence, not implemented right now. - ! - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + associate(tw => wv(1), xit => wv(2)) + + select case (init_) + case('Z') + call xit%zero() + case('Y') + call psb_geaxpby(done,y,dzero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(done,initu,dzero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') goto 9999 - - end if - - case default + end select + + select case(trans_) + case('N') + if (sv%eps <=dzero) then + ! + ! Fixed number of iterations + ! + ! + do itx=1,sv%sweeps + call psb_geaxpby(done,x,dzero,tw,desc_data,info) + ! Update with U. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-done,sv%u,xit,done,tw,desc_data,info,doswap=.false.) + call psb_spsm(done,sv%l,tw,dzero,xit,desc_data,info) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if + + case default info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='Invalid TRANS in GS subsolve') - goto 9999 - end select + & a_err='Invalid TRANS in GS subsolve') + goto 9999 + end select - if (info /= psb_success_) then + if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in subsolve') - goto 9999 - endif - call tw%free(info) - call xit%free(info) + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + end associate + if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then else diff --git a/mlprec/impl/solver/mld_d_ilu_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_ilu_solver_apply_vect.f90 index 5957613f..9a65dfee 100644 --- a/mlprec/impl/solver/mld_d_ilu_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_d_ilu_solver_apply_vect.f90 @@ -125,48 +125,56 @@ subroutine mld_d_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(tw1,desc_data,info,mold=x%v,scratch=.true.) - select case(trans_) - case('N') - call psb_spsm(done,sv%l,x,dzero,tw,desc_data,info,& - & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) + if (size(wv) < 2) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid wv size') + goto 9999 + end if - if (info == psb_success_) call psb_spsm(alpha,sv%u,tw,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) + + associate(tw => wv(1), tw1 => wv(2)) - case('T') - call psb_spsm(done,sv%u,x,dzero,tw,desc_data,info,& - & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) - if (info == psb_success_) call psb_spsm(alpha,sv%l,tw,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) + select case(trans_) + case('N') + call psb_spsm(done,sv%l,x,dzero,tw,desc_data,info,& + & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) - case('C') + if (info == psb_success_) call psb_spsm(alpha,sv%u,tw,beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) - call psb_spsm(done,sv%u,x,dzero,tw,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) + case('T') + call psb_spsm(done,sv%u,x,dzero,tw,desc_data,info,& + & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) + if (info == psb_success_) call psb_spsm(alpha,sv%l,tw,beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) - call tw1%mlt(done,sv%dv,tw,dzero,info,conjgx=trans_) + case('C') - if (info == psb_success_) call psb_spsm(alpha,sv%l,tw1,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) + call psb_spsm(done,sv%u,x,dzero,tw,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid TRANS in ILU subsolve') - goto 9999 - end select + call tw1%mlt(done,sv%dv,tw,dzero,info,conjgx=trans_) + if (info == psb_success_) call psb_spsm(alpha,sv%l,tw1,beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) - if (info /= psb_success_) then + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid TRANS in ILU subsolve') + goto 9999 + end select - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in subsolve') - goto 9999 - endif - call tw%free(info) - call tw1%free(info) + + if (info /= psb_success_) then + + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + end associate + if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then else diff --git a/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 index 02236ce7..6a7c6adf 100644 --- a/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 @@ -54,7 +54,6 @@ subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& type(psb_s_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, itx - type(psb_s_vect_type) :: tw, xit real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) real(psb_spk_), allocatable :: temp(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -121,69 +120,76 @@ subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) - select case (init_) - case('Z') - call xit%zero() - case('Y') - call psb_geaxpby(sone,y,szero,xit,desc_data,info) - case('U') - if (.not.present(initu)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='missing initu to smoother_apply') - goto 9999 - end if - call psb_geaxpby(sone,initu,szero,xit,desc_data,info) - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong init to smoother_apply') + if (size(wv) < 2) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid wv size') goto 9999 - end select - - select case(trans_) - case('N') - if (sv%eps <=szero) then - ! - ! Fixed number of iterations - ! - ! - do itx=1,sv%sweeps - call psb_geaxpby(sone,x,szero,tw,desc_data,info) - ! Update with L. The off-diagonal block is taken care - ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-sone,sv%l,xit,sone,tw,desc_data,info,doswap=.false.) - call psb_spsm(sone,sv%u,tw,szero,xit,desc_data,info) - end do - - call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + end if - else - ! - ! Iterations to convergence, not implemented right now. - ! - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + associate(tw => wv(1), xit => wv(2)) + + select case (init_) + case('Z') + call xit%zero() + case('Y') + call psb_geaxpby(sone,y,szero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(sone,initu,szero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') goto 9999 - - end if - - case default + end select + + select case(trans_) + case('N') + if (sv%eps <=szero) then + ! + ! Fixed number of iterations + ! + ! + do itx=1,sv%sweeps + call psb_geaxpby(sone,x,szero,tw,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-sone,sv%l,xit,sone,tw,desc_data,info,doswap=.false.) + call psb_spsm(sone,sv%u,tw,szero,xit,desc_data,info) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if + + case default info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='Invalid TRANS in GS subsolve') - goto 9999 - end select + & a_err='Invalid TRANS in GS subsolve') + goto 9999 + end select - if (info /= psb_success_) then + if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in subsolve') - goto 9999 - endif - call tw%free(info) - call xit%free(info) + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + end associate + if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then else diff --git a/mlprec/impl/solver/mld_s_gs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_gs_solver_apply_vect.f90 index 36e676fb..23176531 100644 --- a/mlprec/impl/solver/mld_s_gs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_s_gs_solver_apply_vect.f90 @@ -54,7 +54,6 @@ subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& type(psb_s_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, itx - type(psb_s_vect_type) :: tw, xit real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) real(psb_spk_), allocatable :: temp(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -121,69 +120,76 @@ subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) - select case (init_) - case('Z') - call xit%zero() - case('Y') - call psb_geaxpby(sone,y,szero,xit,desc_data,info) - case('U') - if (.not.present(initu)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='missing initu to smoother_apply') - goto 9999 - end if - call psb_geaxpby(sone,initu,szero,xit,desc_data,info) - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong init to smoother_apply') + if (size(wv) < 2) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid wv size') goto 9999 - end select - - select case(trans_) - case('N') - if (sv%eps <=szero) then - ! - ! Fixed number of iterations - ! - ! - do itx=1,sv%sweeps - call psb_geaxpby(sone,x,szero,tw,desc_data,info) - ! Update with U. The off-diagonal block is taken care - ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-sone,sv%u,xit,sone,tw,desc_data,info,doswap=.false.) - call psb_spsm(sone,sv%l,tw,szero,xit,desc_data,info) - end do - - call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + end if - else - ! - ! Iterations to convergence, not implemented right now. - ! - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + associate(tw => wv(1), xit => wv(2)) + + select case (init_) + case('Z') + call xit%zero() + case('Y') + call psb_geaxpby(sone,y,szero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(sone,initu,szero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') goto 9999 - - end if - - case default + end select + + select case(trans_) + case('N') + if (sv%eps <=szero) then + ! + ! Fixed number of iterations + ! + ! + do itx=1,sv%sweeps + call psb_geaxpby(sone,x,szero,tw,desc_data,info) + ! Update with U. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-sone,sv%u,xit,sone,tw,desc_data,info,doswap=.false.) + call psb_spsm(sone,sv%l,tw,szero,xit,desc_data,info) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if + + case default info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='Invalid TRANS in GS subsolve') - goto 9999 - end select + & a_err='Invalid TRANS in GS subsolve') + goto 9999 + end select - if (info /= psb_success_) then + if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in subsolve') - goto 9999 - endif - call tw%free(info) - call xit%free(info) + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + end associate + if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then else diff --git a/mlprec/impl/solver/mld_s_ilu_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_ilu_solver_apply_vect.f90 index b5038235..8b969820 100644 --- a/mlprec/impl/solver/mld_s_ilu_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_s_ilu_solver_apply_vect.f90 @@ -125,48 +125,56 @@ subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(tw1,desc_data,info,mold=x%v,scratch=.true.) - select case(trans_) - case('N') - call psb_spsm(sone,sv%l,x,szero,tw,desc_data,info,& - & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) + if (size(wv) < 2) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid wv size') + goto 9999 + end if - if (info == psb_success_) call psb_spsm(alpha,sv%u,tw,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) + + associate(tw => wv(1), tw1 => wv(2)) - case('T') - call psb_spsm(sone,sv%u,x,szero,tw,desc_data,info,& - & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) - if (info == psb_success_) call psb_spsm(alpha,sv%l,tw,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) + select case(trans_) + case('N') + call psb_spsm(sone,sv%l,x,szero,tw,desc_data,info,& + & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) - case('C') + if (info == psb_success_) call psb_spsm(alpha,sv%u,tw,beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) - call psb_spsm(sone,sv%u,x,szero,tw,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) + case('T') + call psb_spsm(sone,sv%u,x,szero,tw,desc_data,info,& + & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) + if (info == psb_success_) call psb_spsm(alpha,sv%l,tw,beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) - call tw1%mlt(sone,sv%dv,tw,szero,info,conjgx=trans_) + case('C') - if (info == psb_success_) call psb_spsm(alpha,sv%l,tw1,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) + call psb_spsm(sone,sv%u,x,szero,tw,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid TRANS in ILU subsolve') - goto 9999 - end select + call tw1%mlt(sone,sv%dv,tw,szero,info,conjgx=trans_) + if (info == psb_success_) call psb_spsm(alpha,sv%l,tw1,beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) - if (info /= psb_success_) then + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid TRANS in ILU subsolve') + goto 9999 + end select - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in subsolve') - goto 9999 - endif - call tw%free(info) - call tw1%free(info) + + if (info /= psb_success_) then + + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + end associate + if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then else diff --git a/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 index 76c188dc..8adf6f4f 100644 --- a/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 @@ -54,7 +54,6 @@ subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& type(psb_z_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, itx - type(psb_z_vect_type) :: tw, xit complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) complex(psb_dpk_), allocatable :: temp(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -121,69 +120,76 @@ subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) - select case (init_) - case('Z') - call xit%zero() - case('Y') - call psb_geaxpby(zone,y,zzero,xit,desc_data,info) - case('U') - if (.not.present(initu)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='missing initu to smoother_apply') - goto 9999 - end if - call psb_geaxpby(zone,initu,zzero,xit,desc_data,info) - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong init to smoother_apply') + if (size(wv) < 2) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid wv size') goto 9999 - end select - - select case(trans_) - case('N') - if (sv%eps <=dzero) then - ! - ! Fixed number of iterations - ! - ! - do itx=1,sv%sweeps - call psb_geaxpby(zone,x,zzero,tw,desc_data,info) - ! Update with L. The off-diagonal block is taken care - ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-zone,sv%l,xit,zone,tw,desc_data,info,doswap=.false.) - call psb_spsm(zone,sv%u,tw,zzero,xit,desc_data,info) - end do - - call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + end if - else - ! - ! Iterations to convergence, not implemented right now. - ! - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + associate(tw => wv(1), xit => wv(2)) + + select case (init_) + case('Z') + call xit%zero() + case('Y') + call psb_geaxpby(zone,y,zzero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(zone,initu,zzero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') goto 9999 - - end if - - case default + end select + + select case(trans_) + case('N') + if (sv%eps <=dzero) then + ! + ! Fixed number of iterations + ! + ! + do itx=1,sv%sweeps + call psb_geaxpby(zone,x,zzero,tw,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-zone,sv%l,xit,zone,tw,desc_data,info,doswap=.false.) + call psb_spsm(zone,sv%u,tw,zzero,xit,desc_data,info) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if + + case default info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='Invalid TRANS in GS subsolve') - goto 9999 - end select + & a_err='Invalid TRANS in GS subsolve') + goto 9999 + end select - if (info /= psb_success_) then + if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in subsolve') - goto 9999 - endif - call tw%free(info) - call xit%free(info) + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + end associate + if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then else diff --git a/mlprec/impl/solver/mld_z_gs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_gs_solver_apply_vect.f90 index ad56461e..469197d9 100644 --- a/mlprec/impl/solver/mld_z_gs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_z_gs_solver_apply_vect.f90 @@ -54,7 +54,6 @@ subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& type(psb_z_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, itx - type(psb_z_vect_type) :: tw, xit complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) complex(psb_dpk_), allocatable :: temp(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -121,69 +120,76 @@ subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) - select case (init_) - case('Z') - call xit%zero() - case('Y') - call psb_geaxpby(zone,y,zzero,xit,desc_data,info) - case('U') - if (.not.present(initu)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='missing initu to smoother_apply') - goto 9999 - end if - call psb_geaxpby(zone,initu,zzero,xit,desc_data,info) - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong init to smoother_apply') + if (size(wv) < 2) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid wv size') goto 9999 - end select - - select case(trans_) - case('N') - if (sv%eps <=dzero) then - ! - ! Fixed number of iterations - ! - ! - do itx=1,sv%sweeps - call psb_geaxpby(zone,x,zzero,tw,desc_data,info) - ! Update with U. The off-diagonal block is taken care - ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-zone,sv%u,xit,zone,tw,desc_data,info,doswap=.false.) - call psb_spsm(zone,sv%l,tw,zzero,xit,desc_data,info) - end do - - call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + end if - else - ! - ! Iterations to convergence, not implemented right now. - ! - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + associate(tw => wv(1), xit => wv(2)) + + select case (init_) + case('Z') + call xit%zero() + case('Y') + call psb_geaxpby(zone,y,zzero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(zone,initu,zzero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') goto 9999 - - end if - - case default + end select + + select case(trans_) + case('N') + if (sv%eps <=dzero) then + ! + ! Fixed number of iterations + ! + ! + do itx=1,sv%sweeps + call psb_geaxpby(zone,x,zzero,tw,desc_data,info) + ! Update with U. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-zone,sv%u,xit,zone,tw,desc_data,info,doswap=.false.) + call psb_spsm(zone,sv%l,tw,zzero,xit,desc_data,info) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if + + case default info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='Invalid TRANS in GS subsolve') - goto 9999 - end select + & a_err='Invalid TRANS in GS subsolve') + goto 9999 + end select - if (info /= psb_success_) then + if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in subsolve') - goto 9999 - endif - call tw%free(info) - call xit%free(info) + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + end associate + if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then else diff --git a/mlprec/impl/solver/mld_z_ilu_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_ilu_solver_apply_vect.f90 index 980c777f..b7013d46 100644 --- a/mlprec/impl/solver/mld_z_ilu_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_z_ilu_solver_apply_vect.f90 @@ -125,48 +125,56 @@ subroutine mld_z_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& goto 9999 end if - call psb_geasb(tw,desc_data,info,mold=x%v,scratch=.true.) - call psb_geasb(tw1,desc_data,info,mold=x%v,scratch=.true.) - select case(trans_) - case('N') - call psb_spsm(zone,sv%l,x,zzero,tw,desc_data,info,& - & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) + if (size(wv) < 2) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='invalid wv size') + goto 9999 + end if - if (info == psb_success_) call psb_spsm(alpha,sv%u,tw,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_, work=aux) + + associate(tw => wv(1), tw1 => wv(2)) - case('T') - call psb_spsm(zone,sv%u,x,zzero,tw,desc_data,info,& - & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) - if (info == psb_success_) call psb_spsm(alpha,sv%l,tw,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) + select case(trans_) + case('N') + call psb_spsm(zone,sv%l,x,zzero,tw,desc_data,info,& + & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) - case('C') + if (info == psb_success_) call psb_spsm(alpha,sv%u,tw,beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_, work=aux) - call psb_spsm(zone,sv%u,x,zzero,tw,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) + case('T') + call psb_spsm(zone,sv%u,x,zzero,tw,desc_data,info,& + & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) + if (info == psb_success_) call psb_spsm(alpha,sv%l,tw,beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) - call tw1%mlt(zone,sv%dv,tw,zzero,info,conjgx=trans_) + case('C') - if (info == psb_success_) call psb_spsm(alpha,sv%l,tw1,beta,y,desc_data,info,& - & trans=trans_,scale='U',choice=psb_none_,work=aux) + call psb_spsm(zone,sv%u,x,zzero,tw,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) - case default - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Invalid TRANS in ILU subsolve') - goto 9999 - end select + call tw1%mlt(zone,sv%dv,tw,zzero,info,conjgx=trans_) + if (info == psb_success_) call psb_spsm(alpha,sv%l,tw1,beta,y,desc_data,info,& + & trans=trans_,scale='U',choice=psb_none_,work=aux) - if (info /= psb_success_) then + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Invalid TRANS in ILU subsolve') + goto 9999 + end select - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in subsolve') - goto 9999 - endif - call tw%free(info) - call tw1%free(info) + + if (info /= psb_success_) then + + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + end associate + if (n_col <= size(work)) then if ((4*n_col+n_col) <= size(work)) then else From 9fe63d83875c7373ee632f2e9b8675b4d8d6f2dd Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 12 Dec 2017 11:40:15 +0000 Subject: [PATCH 16/16] Fix call to prec%descr --- tests/fileread/mld_cf_sample.f90 | 2 +- tests/fileread/mld_df_sample.f90 | 2 +- tests/fileread/mld_sf_sample.f90 | 2 +- tests/fileread/mld_zf_sample.f90 | 2 +- tests/pdegen/mld_d_pde2d.f90 | 2 +- tests/pdegen/mld_d_pde3d.f90 | 2 +- tests/pdegen/mld_s_pde2d.f90 | 2 +- tests/pdegen/mld_s_pde3d.f90 | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/fileread/mld_cf_sample.f90 b/tests/fileread/mld_cf_sample.f90 index cee3631d..94ffdec5 100644 --- a/tests/fileread/mld_cf_sample.f90 +++ b/tests/fileread/mld_cf_sample.f90 @@ -516,8 +516,8 @@ program mld_cf_sample call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) + call prec%descr(iout=psb_out_unit) if (iam == psb_root_) then - call prec%descr(info) write(psb_out_unit,'("Matrix: ",a)')mtrx_file write(psb_out_unit,'("Computed solution on ",i8," processors")')np write(psb_out_unit,'("Krylov method : ",a)') trim(s_choice%kmethd) diff --git a/tests/fileread/mld_df_sample.f90 b/tests/fileread/mld_df_sample.f90 index dee9bfc8..eef90d4e 100644 --- a/tests/fileread/mld_df_sample.f90 +++ b/tests/fileread/mld_df_sample.f90 @@ -516,8 +516,8 @@ program mld_df_sample call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) + call prec%descr(iout=psb_out_unit) if (iam == psb_root_) then - call prec%descr(info) write(psb_out_unit,'("Matrix: ",a)')mtrx_file write(psb_out_unit,'("Computed solution on ",i8," processors")')np write(psb_out_unit,'("Krylov method : ",a)') trim(s_choice%kmethd) diff --git a/tests/fileread/mld_sf_sample.f90 b/tests/fileread/mld_sf_sample.f90 index df5c1f28..569df707 100644 --- a/tests/fileread/mld_sf_sample.f90 +++ b/tests/fileread/mld_sf_sample.f90 @@ -516,8 +516,8 @@ program mld_sf_sample call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) + call prec%descr(iout=psb_out_unit) if (iam == psb_root_) then - call prec%descr(info) write(psb_out_unit,'("Matrix: ",a)')mtrx_file write(psb_out_unit,'("Computed solution on ",i8," processors")')np write(psb_out_unit,'("Krylov method : ",a)') trim(s_choice%kmethd) diff --git a/tests/fileread/mld_zf_sample.f90 b/tests/fileread/mld_zf_sample.f90 index 91716f87..bb505c1a 100644 --- a/tests/fileread/mld_zf_sample.f90 +++ b/tests/fileread/mld_zf_sample.f90 @@ -516,8 +516,8 @@ program mld_zf_sample call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) + call prec%descr(iout=psb_out_unit) if (iam == psb_root_) then - call prec%descr(info) write(psb_out_unit,'("Matrix: ",a)')mtrx_file write(psb_out_unit,'("Computed solution on ",i8," processors")')np write(psb_out_unit,'("Krylov method : ",a)') trim(s_choice%kmethd) diff --git a/tests/pdegen/mld_d_pde2d.f90 b/tests/pdegen/mld_d_pde2d.f90 index 9b31e101..c21b92ec 100644 --- a/tests/pdegen/mld_d_pde2d.f90 +++ b/tests/pdegen/mld_d_pde2d.f90 @@ -730,8 +730,8 @@ program mld_d_pde2d call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) + call prec%descr(iout=psb_out_unit) if (iam == psb_root_) then - call prec%descr(info) write(psb_out_unit,'("Computed solution on ",i8," processors")') np write(psb_out_unit,'("Krylov method : ",a)') trim(s_choice%kmethd) write(psb_out_unit,'("Preconditioner : ",a)') trim(p_choice%descr) diff --git a/tests/pdegen/mld_d_pde3d.f90 b/tests/pdegen/mld_d_pde3d.f90 index ba87fc99..db898ff0 100644 --- a/tests/pdegen/mld_d_pde3d.f90 +++ b/tests/pdegen/mld_d_pde3d.f90 @@ -784,8 +784,8 @@ program mld_d_pde3d call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) + call prec%descr(iout=psb_out_unit) if (iam == psb_root_) then - call prec%descr(info) write(psb_out_unit,'("Computed solution on ",i8," processors")') np write(psb_out_unit,'("Krylov method : ",a)') trim(s_choice%kmethd) write(psb_out_unit,'("Preconditioner : ",a)') trim(p_choice%descr) diff --git a/tests/pdegen/mld_s_pde2d.f90 b/tests/pdegen/mld_s_pde2d.f90 index 2c590f22..2c7b6de4 100644 --- a/tests/pdegen/mld_s_pde2d.f90 +++ b/tests/pdegen/mld_s_pde2d.f90 @@ -730,8 +730,8 @@ program mld_s_pde2d call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) + call prec%descr(iout=psb_out_unit) if (iam == psb_root_) then - call prec%descr(info) write(psb_out_unit,'("Computed solution on ",i8," processors")') np write(psb_out_unit,'("Krylov method : ",a)') trim(s_choice%kmethd) write(psb_out_unit,'("Preconditioner : ",a)') trim(p_choice%descr) diff --git a/tests/pdegen/mld_s_pde3d.f90 b/tests/pdegen/mld_s_pde3d.f90 index b454ed25..226441ce 100644 --- a/tests/pdegen/mld_s_pde3d.f90 +++ b/tests/pdegen/mld_s_pde3d.f90 @@ -784,8 +784,8 @@ program mld_s_pde3d call psb_sum(ictxt,amatsize) call psb_sum(ictxt,descsize) call psb_sum(ictxt,precsize) + call prec%descr(iout=psb_out_unit) if (iam == psb_root_) then - call prec%descr(info) write(psb_out_unit,'("Computed solution on ",i8," processors")') np write(psb_out_unit,'("Krylov method : ",a)') trim(s_choice%kmethd) write(psb_out_unit,'("Preconditioner : ",a)') trim(p_choice%descr)