fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-20 04:42:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

psblas3:

Browse Source 
base/modules/psb_d_tools_mod.f90
 base/modules/psb_d_vect_mod.f90
 base/tools/psb_dasb.f90

Defined new ASB(,,scratch=.true.)
This commit is contained in:
Salvatore Filippone
2011-11-18 14:41:41 +00:00
parent 5f4eca7cd2
commit 3d6e8bc1a7
3 changed files with 63 additions and 41 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/psb_d_tools_mod.f90
+10 -8
View File
@@ -76,24 +76,26 @@ Module psb_d_tools_mod
subroutine psb_dasbv(x, desc_a, info)
use psb_descriptor_type, only : psb_desc_type, psb_dpk_
type(psb_desc_type), intent(in) :: desc_a
real(psb_dpk_), allocatable, intent(inout) :: x(:)
integer, intent(out) :: info
real(psb_dpk_), allocatable, intent(inout) :: x(:)
integer, intent(out) :: info
end subroutine psb_dasbv
subroutine psb_dasb_vect(x, desc_a, info,mold)
subroutine psb_dasb_vect(x, desc_a, info,mold, scratch)
use psb_descriptor_type, only : psb_desc_type, psb_dpk_
use psb_d_vect_mod
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(in) :: desc_a
type(psb_d_vect_type), intent(inout) :: x
integer, intent(out) :: info
integer, intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
end subroutine psb_dasb_vect
subroutine psb_dasb_vect_r2(x, desc_a, info,mold)
subroutine psb_dasb_vect_r2(x, desc_a, info,mold, scratch)
use psb_descriptor_type, only : psb_desc_type, psb_dpk_
use psb_d_vect_mod
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(in) :: desc_a
type(psb_d_vect_type), intent(inout) :: x(:)
integer, intent(out) :: info
integer, intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
end subroutine psb_dasb_vect_r2
end interface
base/modules/psb_d_vect_mod.f90
+3 -3
View File
@@ -488,10 +488,10 @@ contains
subroutine d_vect_cnv(x,mold)
class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in) :: mold
class(psb_d_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(in) :: mold
class(psb_d_base_vect_type), allocatable :: tmp
real(psb_dpk_), allocatable :: invect(:)
real(psb_dpk_), allocatable :: invect(:)
integer :: info
allocate(tmp,stat=info,mold=mold)
base/tools/psb_dasb.f90
+50 -30
View File
@@ -250,18 +250,20 @@ subroutine psb_dasbv(x, desc_a, info)
end subroutine psb_dasbv
subroutine psb_dasb_vect(x, desc_a, info, mold)
subroutine psb_dasb_vect(x, desc_a, info, mold, scratch)
use psb_base_mod, psb_protect_name => psb_dasb_vect
implicit none
type(psb_desc_type), intent(in) :: desc_a
type(psb_d_vect_type), intent(inout) :: x
integer, intent(out) :: info
integer, intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
! local variables
integer :: ictxt,np,me
integer :: int_err(5), i1sz,nrow,ncol, err_act
logical :: scratch_
integer :: debug_level, debug_unit
character(len=20) :: name,ch_err
@@ -275,6 +277,8 @@ subroutine psb_dasb_vect(x, desc_a, info, mold)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
@@ -293,20 +297,24 @@ subroutine psb_dasb_vect(x, desc_a, info, mold)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
call x%asb(ncol,info)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
if (present(mold)) then
call x%cnv(mold)
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
if (scratch_) then
call x%free(info)
call x%bld(ncol,mold=mold)
else
call x%asb(ncol,info)
! ..update halo elements..
call psb_halo(x,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
if (present(mold)) then
call x%cnv(mold)
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
endif
call psb_erractionrestore(err_act)
return
@@ -321,7 +329,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold)
end subroutine psb_dasb_vect
subroutine psb_dasb_vect_r2(x, desc_a, info, mold)
subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch)
use psb_base_mod, psb_protect_name => psb_dasb_vect_r2
implicit none
@@ -329,10 +337,12 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold)
type(psb_d_vect_type), intent(inout) :: x(:)
integer, intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
! local variables
integer :: ictxt,np,me, i, n
integer :: int_err(5), i1sz,nrow,ncol, err_act
logical :: scratch_
integer :: debug_level, debug_unit
character(len=20) :: name,ch_err
@@ -345,6 +355,8 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold)
ictxt = desc_a%get_context()
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ictxt, me, np)
@@ -365,20 +377,28 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol
do i=1, n
call x(i)%asb(ncol,info)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)
if (info /= 0) exit
if (present(mold)) then
call x(i)%cnv(mold)
if (scratch_) then
do i=1,n
call x(i)%free(info)
call x(i)%bld(ncol,mold=mold)
end do
else
do i=1, n
call x(i)%asb(ncol,info)
if (info /= 0) exit
! ..update halo elements..
call psb_halo(x(i),desc_a,info)
if (info /= 0) exit
if (present(mold)) then
call x(i)%cnv(mold)
end if
end do
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
end do
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_halo')
goto 9999
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'