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

psblas3:

Browse Source 
base/internals/psb_indx_map_fnd_owner.F90
 base/modules/psb_base_tools_mod.f90
 base/modules/psb_desc_const_mod.f90
 base/modules/psb_indx_map_mod.f90
 base/tools/psb_cd_inloc.f90
 base/tools/psb_cdall.f90
 base/tools/psb_cdals.f90
 base/tools/psb_cdalv.f90
 base/tools/psb_cdcpy.F90
 base/tools/psb_icdasb.F90
 util/psb_mat_dist_impl.f90

Added tempvg and parts components in indxmap. 
Revised declaration of PARTS subroutine.
psblas3-type-indexed
Salvatore Filippone 13 years ago
parent 88db62fa7b
commit 419e5b4af5
11 changed files with 222 additions and 2043 deletions
Show Stats Download Patch File Download Diff File

41
base/internals/psb_indx_map_fnd_owner.F90
Unescape Escape View File

@ -70,7 +70,7 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
& sdsz(:),sdidx(:), rvsz(:), rvidx(:),answers(:,:),idxsrch(:,:) & sdsz(:),sdidx(:), rvsz(:), rvidx(:),answers(:,:),idxsrch(:,:)
integer(psb_ipk_) :: i,n_row,n_col,err_act,ih,icomm,hsize,ip,isz,k,j,& integer(psb_ipk_) :: i,n_row,n_col,err_act,ih,icomm,hsize,ip,isz,k,j,&
& last_ih, last_j, nv & last_ih, last_j, nv, mglob, nresp
integer(psb_ipk_) :: ictxt,np,me integer(psb_ipk_) :: ictxt,np,me
logical, parameter :: gettime=.false. logical, parameter :: gettime=.false.
real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx
@ -82,6 +82,7 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
ictxt = idxmap%get_ctxt() ictxt = idxmap%get_ctxt()
icomm = idxmap%get_mpic() icomm = idxmap%get_mpic()
mglob = idxmap%get_gr()
n_row = idxmap%get_lr() n_row = idxmap%get_lr()
n_col = idxmap%get_lc() n_col = idxmap%get_lc()
@ -104,6 +105,38 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
end if end if
nv = size(idx) nv = size(idx)
call psb_realloc(nv,iprc,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_realloc')
goto 9999
end if
if (associated(idxmap%parts)) then
! Use function shortcut
!!$ write(0,*) me,trim(name),' indxmap%parts shortcut'
Allocate(hidx(np), stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999
end if
do i=1, nv
call idxmap%parts(idx(i),mglob,np,hidx,nresp)
if (nresp > 0) then
iprc(i) = hidx(1)
else
iprc(i) = -1
end if
end do
else if (allocated(idxmap%tempvg)) then
!!$ write(0,*) me,trim(name),' indxmap%tempvg shortcut'
! Use temporary vector
do i=1, nv
iprc(i) = idxmap%tempvg(idx(i))
end do
else
! !
! The basic idea is very simple. ! The basic idea is very simple.
! First we collect (to all) all the requests. ! First we collect (to all) all the requests.
@ -213,11 +246,6 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
call psb_msort(idxsrch(1:nv,1),ix=idxsrch(1:nv,2)) call psb_msort(idxsrch(1:nv,1),ix=idxsrch(1:nv,2))
! Now extract the answers for our local query ! Now extract the answers for our local query
call psb_realloc(nv,iprc,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_realloc')
goto 9999
end if
last_ih = -1 last_ih = -1
last_j = -1 last_j = -1
j = 1 j = 1
@ -267,6 +295,7 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
end do end do
end if end if
end do end do
end if
if (gettime) then if (gettime) then
call psb_barrier(ictxt) call psb_barrier(ictxt)

4
base/modules/psb_base_tools_mod.f90
Unescape Escape View File

@ -423,9 +423,9 @@ module psb_cd_tools_mod
interface psb_cdall interface psb_cdall
subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalcheck) subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalcheck)
import :: psb_ipk_, psb_desc_type import :: psb_ipk_, psb_desc_type, psb_parts
implicit None implicit None
include 'parts.fh' procedure(psb_parts) :: parts
integer(psb_ipk_), intent(in) :: mg,ng,ictxt, vg(:), vl(:),nl integer(psb_ipk_), intent(in) :: mg,ng,ictxt, vg(:), vl(:),nl
integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(in) :: flag
logical, intent(in) :: repl, globalcheck logical, intent(in) :: repl, globalcheck

8
base/modules/psb_desc_const_mod.f90
Unescape Escape View File

@ -119,4 +119,12 @@ module psb_desc_const_mod
integer(psb_ipk_), parameter :: psb_ovrlp_elem_to_=2, psb_ovrlp_elem_=0 integer(psb_ipk_), parameter :: psb_ovrlp_elem_to_=2, psb_ovrlp_elem_=0
integer(psb_ipk_), parameter :: psb_n_dom_ovr_=1 integer(psb_ipk_), parameter :: psb_n_dom_ovr_=1
interface
subroutine psb_parts(glob_index,nrow,np,pv,nv)
import :: psb_ipk_
integer(psb_ipk_), intent (in) :: glob_index,np,nrow
integer(psb_ipk_), intent (out) :: nv, pv(*)
end subroutine psb_parts
end interface
end module psb_desc_const_mod end module psb_desc_const_mod

4
base/modules/psb_indx_map_mod.f90
Unescape Escape View File

@ -96,6 +96,10 @@ module psb_indx_map_mod
integer(psb_ipk_) :: local_rows = -1 integer(psb_ipk_) :: local_rows = -1
integer(psb_ipk_) :: local_cols = -1 integer(psb_ipk_) :: local_cols = -1
procedure(psb_parts), nopass, pointer :: parts => null()
integer(psb_ipk_), allocatable :: tempvg(:)
integer(psb_ipk_), allocatable :: oracle(:,:)
contains contains
procedure, pass(idxmap) :: get_state => base_get_state procedure, pass(idxmap) :: get_state => base_get_state

31
base/tools/psb_cd_inloc.f90
Unescape Escape View File

@ -289,7 +289,6 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck)
& stat=info) & stat=info)
if (info == psb_success_) then if (info == psb_success_) then
desc%lprm(1) = 0 desc%lprm(1) = 0
!!$ desc%matrix_data(:) = 0
end if end if
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_alloc_request_ info=psb_err_alloc_request_
@ -299,11 +298,6 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck)
endif endif
temp_ovrlap(:) = -1 temp_ovrlap(:) = -1
!!$ desc%matrix_data(psb_m_) = m
!!$ desc%matrix_data(psb_n_) = n
!!$ ! This has to be set BEFORE any call to SET_BLD
!!$ desc%matrix_data(psb_ctxt_) = ictxt
!!$ call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_))
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
@ -371,31 +365,6 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck)
goto 9999 goto 9999
endif endif
!!$ ! set fields in desc%MATRIX_DATA....
!!$ desc%matrix_data(psb_n_row_) = loc_row
!!$ desc%matrix_data(psb_n_col_) = loc_row
!!$ call psb_realloc(max(1,loc_row/2),desc%halo_index, info)
!!$ if (info == psb_success_) call psb_realloc(1,desc%ext_index, info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='psb_realloc')
!!$ Goto 9999
!!$ end if
!!$ desc%matrix_data(psb_pnt_h_) = 1
!!$ desc%halo_index(:) = -1
!!$ desc%ext_index(:) = -1
!!$
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),': end'
!!$
!!$ call psb_cd_set_bld(desc,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='psb_cd_set_bld')
!!$ Goto 9999
!!$ end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

7
base/tools/psb_cdall.f90
Unescape Escape View File

@ -7,7 +7,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
use psb_base_tools_mod, psb_protect_name => psb_cdall use psb_base_tools_mod, psb_protect_name => psb_cdall
use psi_mod use psi_mod
implicit None implicit None
include 'parts.fh' procedure(psb_parts) :: parts
integer(psb_ipk_), intent(in) :: mg,ng,ictxt, vg(:), vl(:),nl integer(psb_ipk_), intent(in) :: mg,ng,ictxt, vg(:), vl(:),nl
integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(in) :: flag
logical, intent(in) :: repl, globalcheck logical, intent(in) :: repl, globalcheck
@ -19,7 +19,7 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
interface interface
subroutine psb_cdals(m, n, parts, ictxt, desc, info) subroutine psb_cdals(m, n, parts, ictxt, desc, info)
use psb_descriptor_type use psb_descriptor_type
include 'parts.fh' procedure(psb_parts) :: parts
integer(psb_ipk_), intent(in) :: m,n,ictxt integer(psb_ipk_), intent(in) :: m,n,ictxt
Type(psb_desc_type), intent(out) :: desc Type(psb_desc_type), intent(out) :: desc
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
@ -168,12 +168,9 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche
call psb_errpush(info,name,a_err='psb_realloc') call psb_errpush(info,name,a_err='psb_realloc')
Goto 999 Goto 999
end if end if
!!$ desc%matrix_data(psb_pnt_h_) = 1
desc%halo_index(:) = -1 desc%halo_index(:) = -1
desc%ext_index(:) = -1 desc%ext_index(:) = -1
call psb_cd_set_bld(desc,info) call psb_cd_set_bld(desc,info)
!!$ desc%matrix_data(psb_n_row_) = desc%indxmap%get_lr()
!!$ desc%matrix_data(psb_n_col_) = desc%indxmap%get_lc()
if (info /= psb_success_) goto 999 if (info /= psb_success_) goto 999
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)

21
base/tools/psb_cdals.f90
Unescape Escape View File

@ -50,7 +50,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
use psb_list_map_mod use psb_list_map_mod
use psb_hash_map_mod use psb_hash_map_mod
implicit None implicit None
include 'parts.fh' procedure(psb_parts) :: parts
!....Parameters... !....Parameters...
integer(psb_ipk_), intent(in) :: M,N,ictxt integer(psb_ipk_), intent(in) :: M,N,ictxt
Type(psb_desc_type), intent(out) :: desc Type(psb_desc_type), intent(out) :: desc
@ -125,9 +125,6 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
! count local rows number ! count local rows number
loc_row = max(1,(m+np-1)/np) loc_row = max(1,(m+np-1)/np)
! allocate work vector ! allocate work vector
!!$ allocate(desc%matrix_data(psb_mdata_size_),&
!!$ & temp_ovrlap(max(1,2*loc_row)), prc_v(np),stat=info)
!!$ desc%matrix_data(:) = 0
allocate(temp_ovrlap(max(1,2*loc_row)), prc_v(np),stat=info) allocate(temp_ovrlap(max(1,2*loc_row)), prc_v(np),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -137,12 +134,6 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
call psb_errpush(err,name,int_err,a_err='integer') call psb_errpush(err,name,int_err,a_err='integer')
goto 9999 goto 9999
endif endif
!!$ desc%matrix_data(psb_m_) = m
!!$ desc%matrix_data(psb_n_) = n
!!$ ! This has to be set BEFORE any call to SET_BLD
!!$ desc%matrix_data(psb_ctxt_) = ictxt
!!$ call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_))
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': starting main loop' ,info & write(debug_unit,*) me,' ',trim(name),': starting main loop' ,info
@ -171,6 +162,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
allocate(psb_repl_map :: desc%indxmap, stat=info) allocate(psb_repl_map :: desc%indxmap, stat=info)
else else
allocate(psb_hash_map :: desc%indxmap, stat=info) allocate(psb_hash_map :: desc%indxmap, stat=info)
desc%indxmap%parts => parts
end if end if
end if end if
@ -289,15 +281,6 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info)
Goto 9999 Goto 9999
endif endif
!!$ ! set fields in desc%MATRIX_DATA....
!!$ desc%matrix_data(psb_n_row_) = loc_row
!!$ desc%matrix_data(psb_n_col_) = loc_row
!!$ write(0,*) me,'CDALS: after init ', &
!!$ & desc%indxmap%get_gr(), &
!!$ & desc%indxmap%get_gc(), &
!!$ & desc%indxmap%get_lr(), &
!!$ & desc%indxmap%get_lc()
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end' & write(debug_unit,*) me,' ',trim(name),': end'

11
base/tools/psb_cdalv.f90
Unescape Escape View File

@ -144,11 +144,6 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag)
call psb_errpush(info,name,i_err=int_err,a_err='integer') call psb_errpush(info,name,i_err=int_err,a_err='integer')
goto 9999 goto 9999
endif endif
!!$ desc%matrix_data(psb_m_) = m
!!$ desc%matrix_data(psb_n_) = n
!!$ ! This has to be set BEFORE any call to SET_BLD
!!$ desc%matrix_data(psb_ctxt_) = ictxt
!!$ call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_))
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': starting main loop' ,info & write(debug_unit,*) me,' ',trim(name),': starting main loop' ,info
@ -181,6 +176,8 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag)
else else
if (psb_cd_choose_large_state(ictxt,m)) then if (psb_cd_choose_large_state(ictxt,m)) then
allocate(psb_hash_map :: desc%indxmap, stat=info) allocate(psb_hash_map :: desc%indxmap, stat=info)
if (info == 0) allocate(desc%indxmap%tempvg(m),stat=info)
if (info ==0) desc%indxmap%tempvg(1:m) = v(1:m) - flag_
else else
allocate(psb_glist_map :: desc%indxmap, stat=info) allocate(psb_glist_map :: desc%indxmap, stat=info)
end if end if
@ -211,10 +208,6 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag)
goto 9999 goto 9999
endif endif
!!$ ! set fields in desc%MATRIX_DATA....
!!$ desc%matrix_data(psb_n_row_) = loc_row
!!$ desc%matrix_data(psb_n_col_) = loc_row
!!$
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end' & write(debug_unit,*) me,' ',trim(name),': end'

6
base/tools/psb_cdcpy.F90
Unescape Escape View File

@ -86,12 +86,6 @@ subroutine psb_cdcpy(desc_in, desc_out, info)
if (allocated(desc_in%indxmap)) then if (allocated(desc_in%indxmap)) then
!!$ if (allocated(desc_out%indxmap)) then
!!$ ! This should never happen
!!$ call desc_out%indxmap%free()
!!$ deallocate(desc_out%indxmap)
!!$ end if
!!$ write(debug_unit,*) me,' ',trim(name),': Calling allocate(SOURCE = )'
#ifdef SOURCE_WORKAROUND #ifdef SOURCE_WORKAROUND
call desc_in%indxmap%clone(desc_out%indxmap,info) call desc_in%indxmap%clone(desc_out%indxmap,info)
#else #else

39
base/tools/psb_icdasb.F90
Unescape Escape View File

@ -36,13 +36,13 @@
! The user callable routine is defined in the psb_tools_mod module. ! The user callable routine is defined in the psb_tools_mod module.
! !
! Arguments: ! Arguments:
! desc_a - type(psb_desc_type). The communication descriptor. ! desc - type(psb_desc_type). The communication descriptor.
! info - integer. return code. ! info - integer. return code.
! ext_hv - logical Essentially this distinguishes a call ! ext_hv - logical Essentially this distinguishes a call
! coming from the build of an extended ! coming from the build of an extended
! halo descriptor with respect to a normal call. ! halo descriptor with respect to a normal call.
! !
subroutine psb_icdasb(desc_a,info,ext_hv) subroutine psb_icdasb(desc,info,ext_hv)
use psb_base_mod, psb_protect_name => psb_icdasb use psb_base_mod, psb_protect_name => psb_icdasb
use psi_mod use psi_mod
#ifdef MPI_MOD #ifdef MPI_MOD
@ -53,7 +53,7 @@ subroutine psb_icdasb(desc_a,info,ext_hv)
include 'mpif.h' include 'mpif.h'
#endif #endif
!...Parameters.... !...Parameters....
type(psb_desc_type), intent(inout) :: desc_a type(psb_desc_type), intent(inout) :: desc
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: ext_hv logical, intent(in), optional :: ext_hv
@ -75,10 +75,10 @@ subroutine psb_icdasb(desc_a,info,ext_hv)
debug_unit = psb_get_debug_unit() debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
ictxt = desc_a%get_context() ictxt = desc%get_context()
dectype = desc_a%get_dectype() dectype = desc%get_dectype()
n_row = desc_a%get_local_rows() n_row = desc%get_local_rows()
n_col = desc_a%get_local_cols() n_col = desc%get_local_cols()
call psb_get_mpicomm(ictxt,icomm ) call psb_get_mpicomm(ictxt,icomm )
! check on blacs grid ! check on blacs grid
@ -89,7 +89,7 @@ subroutine psb_icdasb(desc_a,info,ext_hv)
goto 9999 goto 9999
endif endif
if (.not.psb_is_ok_desc(desc_a)) then if (.not.psb_is_ok_desc(desc)) then
info = psb_err_spmat_invalid_state_ info = psb_err_spmat_invalid_state_
int_err(1) = dectype int_err(1) = dectype
call psb_errpush(info,name) call psb_errpush(info,name)
@ -113,22 +113,22 @@ subroutine psb_icdasb(desc_a,info,ext_hv)
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit, *) me,' ',trim(name),': start' & write(debug_unit, *) me,' ',trim(name),': start'
if (allocated(desc_a%indxmap)) then if (allocated(desc%indxmap)) then
call psi_ldsc_pre_halo(desc_a,ext_hv_,info) call psi_ldsc_pre_halo(desc,ext_hv_,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='ldsc_pre_halo') call psb_errpush(psb_err_from_subroutine_,name,a_err='ldsc_pre_halo')
goto 9999 goto 9999
end if end if
! Take out the lists for ovrlap, halo and ext... ! Take out the lists for ovrlap, halo and ext...
call psb_move_alloc(desc_a%ovrlap_index,ovrlap_index,info) call psb_move_alloc(desc%ovrlap_index,ovrlap_index,info)
call psb_move_alloc(desc_a%halo_index,halo_index,info) call psb_move_alloc(desc%halo_index,halo_index,info)
call psb_move_alloc(desc_a%ext_index,ext_index,info) call psb_move_alloc(desc%ext_index,ext_index,info)
if (debug_level >= psb_debug_ext_) & if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': Final conversion' & write(debug_unit,*) me,' ',trim(name),': Final conversion'
! Then convert and put them back where they belong. ! Then convert and put them back where they belong.
call psi_cnv_dsc(halo_index,ovrlap_index,ext_index,desc_a,info) call psi_cnv_dsc(halo_index,ovrlap_index,ext_index,desc,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_cnv_dsc') call psb_errpush(psb_err_from_subroutine_,name,a_err='psi_cnv_dsc')
@ -142,17 +142,16 @@ subroutine psb_icdasb(desc_a,info,ext_hv)
goto 9999 goto 9999
end if end if
call desc_a%indxmap%asb(info) call desc%indxmap%asb(info)
if (info == psb_success_) then
if (allocated(desc%indxmap%tempvg)) &
& deallocate(desc%indxmap%tempvg,stat=info)
end if
if (info /= psb_success_) then if (info /= psb_success_) then
write(0,*) 'Error from internal indxmap asb ',info write(0,*) 'Error from internal indxmap asb ',info
info = psb_success_ info = psb_success_
end if end if
!!$ desc_a%matrix_data(psb_n_row_) = desc_a%indxmap%get_lr()
!!$ desc_a%matrix_data(psb_n_col_) = desc_a%indxmap%get_lc()
!!$ ! Ok, register into MATRIX_DATA
!!$ desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_
else else
info = psb_err_spmat_invalid_state_ info = psb_err_spmat_invalid_state_
call psb_errpush(info,name) call psb_errpush(info,name)

1797
util/psb_mat_dist_impl.f90
View File

File diff suppressed because it is too large Load Diff
Write Preview
Loading…
Cancel
Save