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

Fixed allocation for large index spaces.

Browse Source
psblas3-type-indexed
Salvatore Filippone 18 years ago
parent 05721fa5fd
commit f03078bfdb
2 changed files with 281 additions and 138 deletions
Show Stats Download Patch File Download Diff File

279
src/tools/psb_cdall.f90
Unescape Escape View File

@ -57,7 +57,7 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info)
!locals !locals
Integer :: counter,i,j,np,me,loc_row,err,loc_col,nprocs,& Integer :: counter,i,j,np,me,loc_row,err,loc_col,nprocs,&
& l_ov_ix,l_ov_el,idx, err_act, itmpov, k, ns & l_ov_ix,l_ov_el,idx, err_act, itmpov, k, ns, glx
integer :: int_err(5),exch(2) integer :: int_err(5),exch(2)
integer, allocatable :: prc_v(:), temp_ovrlap(:), ov_idx(:),ov_el(:) integer, allocatable :: prc_v(:), temp_ovrlap(:), ov_idx(:),ov_el(:)
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
@ -116,13 +116,17 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info)
!count local rows number !count local rows number
! allocate work vector ! allocate work vector
allocate(prc_v(np),desc_a%glob_to_loc(m),& if (m > psb_cd_get_large_threshold()) then
&desc_a%matrix_data(psb_mdata_size_),temp_ovrlap(m),stat=info) allocate(desc_a%matrix_data(psb_mdata_size_),&
if (info /= no_err) then & temp_ovrlap(m),prc_v(np),stat=info)
else
allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),&
& temp_ovrlap(m),prc_v(np),stat=info)
end if
if (info /= 0) then
info=2025 info=2025
err=info
int_err(1)=m int_err(1)=m
call psb_errpush(err,name,int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
endif endif
@ -131,76 +135,188 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info)
counter = 0 counter = 0
itmpov = 0 itmpov = 0
temp_ovrlap(:) = -1 temp_ovrlap(:) = -1
do i=1,m if ( m >psb_cd_get_large_threshold()) then
if (info == 0) then desc_a%matrix_data(psb_dec_type_) = psb_desc_large_bld_
call parts(i,m,np,prc_v,nprocs) loc_col = (m+np-1)/np
if (nprocs > np) then allocate(desc_a%loc_to_glob(loc_col), desc_a%lprm(1),&
info=570 & desc_a%ptree(2),stat=info)
int_err(1)=3 if (info == 0) call InitPairSearchTree(desc_a%ptree,info)
int_err(2)=np if (info /= 0) then
int_err(3)=nprocs info=2025
int_err(4)=i int_err(1)=loc_col
err=info call psb_errpush(info,name,i_err=int_err)
call psb_errpush(err,name,int_err) goto 9999
goto 9999 end if
else if (nprocs <= 0) then
info=575 ! set LOC_TO_GLOB array to all "-1" values
int_err(1)=3 desc_a%lprm(1) = 0
int_err(2)=nprocs desc_a%loc_to_glob(:) = -1
int_err(3)=i k = 0
err=info do i=1,m
call psb_errpush(err,name,int_err) if (info == 0) then
goto 9999 call parts(i,m,np,prc_v,nprocs)
else if (nprocs > np) then
do j=1,nprocs info=570
if ((prc_v(j) > np-1).or.(prc_v(j) < 0)) then int_err(1)=3
info=580 int_err(2)=np
int_err(1)=3 int_err(3)=nprocs
int_err(2)=prc_v(j) int_err(4)=i
int_err(3)=i err=info
err=info call psb_errpush(err,name,int_err)
call psb_errpush(err,name,int_err) goto 9999
goto 9999 else if (nprocs <= 0) then
end if info=575
end do int_err(1)=3
endif int_err(2)=nprocs
desc_a%glob_to_loc(i) = -(np+prc_v(1)+1) int_err(3)=i
j=1 err=info
do call psb_errpush(err,name,int_err)
if (j > nprocs) exit goto 9999
if (prc_v(j) == me) exit else
j=j+1 do j=1,nprocs
enddo if ((prc_v(j) > np-1).or.(prc_v(j) < 0)) then
if (j <= nprocs) then info=580
if (prc_v(j) == me) then int_err(1)=3
! this point belongs to me int_err(2)=prc_v(j)
counter=counter+1 int_err(3)=i
desc_a%glob_to_loc(i) = counter err=info
if (nprocs > 1) then call psb_errpush(err,name,int_err)
if ((itmpov+2+nprocs) > size(temp_ovrlap)) then goto 9999
ns = max(itmpov+2+nprocs,int(1.25*size(temp_ovrlap))) end if
call psb_realloc(ns,temp_ovrlap,info,pad=-1) end do
if (info /= 0) then endif
info=2025 j=1
int_err(1)=m do
err=info if (j > nprocs) exit
call psb_errpush(err,name,int_err) if (prc_v(j) == me) exit
j=j+1
enddo
if (j <= nprocs) then
if (prc_v(j) == me) then
! this point belongs to me
k = k + 1
call psb_check_size((k+1),desc_a%loc_to_glob,info,pad=-1)
if (info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_check_size')
goto 9999
end if
desc_a%loc_to_glob(k) = i
call SearchInsKeyVal(desc_a%ptree,i,k,glx,info)
if (nprocs > 1) then
call psb_check_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1)
if (info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_check_size')
goto 9999 goto 9999
endif end if
itmpov = itmpov + 1
temp_ovrlap(itmpov) = i
itmpov = itmpov + 1
temp_ovrlap(itmpov) = nprocs
temp_ovrlap(itmpov+1:itmpov+nprocs) = prc_v(1:nprocs)
itmpov = itmpov + nprocs
endif endif
itmpov = itmpov + 1 end if
temp_ovrlap(itmpov) = i end if
itmpov = itmpov + 1
temp_ovrlap(itmpov) = nprocs
temp_ovrlap(itmpov+1:itmpov+nprocs) = prc_v(1:nprocs)
itmpov = itmpov + nprocs
endif
end if
end if end if
enddo
if (info /= 0) then
info=4000
call psb_errpush(info,name)
goto 9999
endif endif
enddo loc_row = k
else
desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_
do i=1,m
if (info == 0) then
call parts(i,m,np,prc_v,nprocs)
if (nprocs > np) then
info=570
int_err(1)=3
int_err(2)=np
int_err(3)=nprocs
int_err(4)=i
err=info
call psb_errpush(err,name,int_err)
goto 9999
else if (nprocs <= 0) then
info=575
int_err(1)=3
int_err(2)=nprocs
int_err(3)=i
err=info
call psb_errpush(err,name,int_err)
goto 9999
else
do j=1,nprocs
if ((prc_v(j) > np-1).or.(prc_v(j) < 0)) then
info=580
int_err(1)=3
int_err(2)=prc_v(j)
int_err(3)=i
err=info
call psb_errpush(err,name,int_err)
goto 9999
end if
end do
endif
desc_a%glob_to_loc(i) = -(np+prc_v(1)+1)
j=1
do
if (j > nprocs) exit
if (prc_v(j) == me) exit
j=j+1
enddo
if (j <= nprocs) then
if (prc_v(j) == me) then
! this point belongs to me
counter=counter+1
desc_a%glob_to_loc(i) = counter
if (nprocs > 1) then
call psb_check_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1)
if (info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_check_size')
goto 9999
end if
itmpov = itmpov + 1
temp_ovrlap(itmpov) = i
itmpov = itmpov + 1
temp_ovrlap(itmpov) = nprocs
temp_ovrlap(itmpov+1:itmpov+nprocs) = prc_v(1:nprocs)
itmpov = itmpov + nprocs
endif
end if
end if
endif
enddo
! estimate local cols number
loc_row=counter
loc_col=min(2*loc_row,m)
allocate(desc_a%loc_to_glob(loc_col),&
&desc_a%lprm(1),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
! set LOC_TO_GLOB array to all "-1" values
desc_a%lprm(1) = 0
desc_a%loc_to_glob(:) = -1
do i=1,m
k = desc_a%glob_to_loc(i)
if (k > 0) then
desc_a%loc_to_glob(k) = i
endif
enddo
end if
loc_row=counter
! check on parts function ! check on parts function
if (debug) write(*,*) 'PSB_CDALL: End main loop:' ,loc_row,itmpov,info if (debug) write(*,*) 'PSB_CDALL: End main loop:' ,loc_row,itmpov,info
@ -267,25 +383,6 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info)
call psb_errpush(err,name) call psb_errpush(err,name)
Goto 9999 Goto 9999
endif endif
! estimate local cols number
loc_col=min(2*loc_row,m)
allocate(desc_a%loc_to_glob(loc_col),&
&desc_a%lprm(1),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
! set LOC_TO_GLOB array to all "-1" values
desc_a%lprm(1) = 0
desc_a%loc_to_glob(:) = -1
do i=1,m
k = desc_a%glob_to_loc(i)
if (k > 0) then
desc_a%loc_to_glob(k) = i
endif
enddo
! set fields in desc_a%MATRIX_DATA.... ! set fields in desc_a%MATRIX_DATA....
desc_a%matrix_data(psb_n_row_) = loc_row desc_a%matrix_data(psb_n_row_) = loc_row
@ -301,10 +398,8 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info)
desc_a%halo_index(:) = -1 desc_a%halo_index(:) = -1
desc_a%matrix_data(psb_m_) = m desc_a%matrix_data(psb_m_) = m
desc_a%matrix_data(psb_n_) = n desc_a%matrix_data(psb_n_) = n
desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_
desc_a%matrix_data(psb_ctxt_) = ictxt desc_a%matrix_data(psb_ctxt_) = ictxt
call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_))

140
src/tools/psb_cddec.f90
Unescape Escape View File

@ -117,7 +117,7 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info)
!locals !locals
Integer :: i,j,np,me,err,n,itmpov, k,& Integer :: i,j,np,me,err,n,itmpov, k,&
& l_ov_ix,l_ov_el,idx, err_act,m, ip & l_ov_ix,l_ov_el,idx, err_act,m, ip,glx
Integer :: INT_ERR(5), thalo(1), tovr(1) Integer :: INT_ERR(5), thalo(1), tovr(1)
integer, allocatable :: nlv(:) integer, allocatable :: nlv(:)
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
@ -164,57 +164,105 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info)
!count local rows number !count local rows number
! allocate work vector if ( m >psb_cd_get_large_threshold()) then
!!$ allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),& allocate(desc_a%loc_to_glob(nloc), desc_a%lprm(1),&
!!$ & desc_a%loc_to_glob(nloc),desc_a%lprm(1),& & desc_a%ptree(2),desc_a%matrix_data(psb_mdata_size_),stat=info)
!!$ & desc_a%ovrlap_index(1),desc_a%ovrlap_elem(1),& if (info == 0) call InitPairSearchTree(desc_a%ptree,info)
!!$ & desc_a%halo_index(1),desc_a%bnd_elem(1),stat=info) if (info /= 0) then
allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),& info=2025
& desc_a%loc_to_glob(m),desc_a%lprm(1),stat=info) int_err(1)=nloc
if (info /= 0) then call psb_errpush(info,name,i_err=int_err)
info=2025 goto 9999
int_err(1)=m end if
call psb_errpush(info,name,i_err=int_err)
goto 9999 ! set LOC_TO_GLOB array to all "-1" values
endif desc_a%lprm(1) = 0
desc_a%loc_to_glob(:) = -1
desc_a%matrix_data(psb_n_row_) = nloc
desc_a%matrix_data(psb_n_col_) = nloc
desc_a%matrix_data(psb_m_) = m
desc_a%matrix_data(psb_n_) = m
desc_a%matrix_data(psb_dec_type_) = psb_desc_large_bld_
desc_a%matrix_data(psb_ctxt_) = ictxt
call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_))
do ip=0, np-1
if (ip==me) then
do i=1, nlv(ip)
call SearchInsKeyVal(desc_a%ptree,j,i,glx,info)
desc_a%loc_to_glob(i) = j
j = j + 1
enddo
else
do i=1, nlv(ip)
j = j + 1
enddo
endif
enddo
tovr = -1
thalo = -1
desc_a%lprm(:) = 0
call psi_cnv_dsc(thalo,tovr,desc_a,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='psi_bld_cdesc')
goto 9999
end if
desc_a%matrix_data(psb_dec_type_) = psb_desc_large_asb_
else
desc_a%matrix_data(psb_n_row_) = nloc allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),&
desc_a%matrix_data(psb_n_col_) = nloc & desc_a%loc_to_glob(m),desc_a%lprm(1),stat=info)
desc_a%matrix_data(psb_m_) = m if (info /= 0) then
desc_a%matrix_data(psb_n_) = m info=2025
desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_ int_err(1)=m
desc_a%matrix_data(psb_ctxt_) = ictxt call psb_errpush(info,name,i_err=int_err)
call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_)) goto 9999
j = 1
do ip=0, np-1
if (ip==me) then
do i=1, nlv(ip)
desc_a%glob_to_loc(j) = i
desc_a%loc_to_glob(i) = j
j = j + 1
enddo
else
do i=1, nlv(ip)
desc_a%glob_to_loc(j) = -(np+ip+1)
j = j + 1
enddo
endif endif
enddo
tovr = -1
thalo = -1
desc_a%lprm(:) = 0
call psi_cnv_dsc(thalo,tovr,desc_a,info) desc_a%matrix_data(psb_n_row_) = nloc
if (info /= 0) then desc_a%matrix_data(psb_n_col_) = nloc
call psb_errpush(4010,name,a_err='psi_bld_cdesc') desc_a%matrix_data(psb_m_) = m
goto 9999 desc_a%matrix_data(psb_n_) = m
end if desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_
desc_a%matrix_data(psb_ctxt_) = ictxt
call psb_get_mpicomm(ictxt,desc_a%matrix_data(psb_mpi_c_))
j = 1
do ip=0, np-1
if (ip==me) then
do i=1, nlv(ip)
desc_a%glob_to_loc(j) = i
desc_a%loc_to_glob(i) = j
j = j + 1
enddo
else
do i=1, nlv(ip)
desc_a%glob_to_loc(j) = -(np+ip+1)
j = j + 1
enddo
endif
enddo
tovr = -1
thalo = -1
desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_ desc_a%lprm(:) = 0
call psi_cnv_dsc(thalo,tovr,desc_a,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='psi_bld_cdesc')
goto 9999
end if
desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_
endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

Write Preview
Loading…
Cancel
Save