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

Fixed state vs. size of descriptor in two separate entries in matrix_data,

Browse Source 
making them orthogonal.
Updated tools sources accordingly.
psblas3-type-indexed
Salvatore Filippone 20 years ago
parent 246bd82a93
commit ab8704dd91
10 changed files with 1195 additions and 1060 deletions
Show Stats Download Patch File Download Diff File

13
base/modules/psb_const_mod.f90
Unescape Escape View File

@ -58,21 +58,24 @@ module psb_const_mod
! !
integer, parameter :: psb_dec_type_=1, psb_m_=2,psb_n_=3 integer, parameter :: psb_dec_type_=1, psb_m_=2,psb_n_=3
integer, parameter :: psb_n_row_=4, psb_n_col_=5,psb_ctxt_=6 integer, parameter :: psb_n_row_=4, psb_n_col_=5,psb_ctxt_=6
integer, parameter :: psb_loc_to_glob_=7 integer, parameter :: psb_desc_size_=7
integer, parameter :: psb_ovl_state_=8
integer, parameter :: psb_mpi_c_=9
integer, parameter :: psb_thal_xch_=11 integer, parameter :: psb_thal_xch_=11
integer, parameter :: psb_thal_snd_=12 integer, parameter :: psb_thal_snd_=12
integer, parameter :: psb_thal_rcv_=13 integer, parameter :: psb_thal_rcv_=13
integer, parameter :: psb_tovr_xch_=14 integer, parameter :: psb_tovr_xch_=14
integer, parameter :: psb_tovr_snd_=15 integer, parameter :: psb_tovr_snd_=15
integer, parameter :: psb_tovr_rcv_=16 integer, parameter :: psb_tovr_rcv_=16
integer, parameter :: psb_mpi_c_=9,psb_mdata_size_=20 integer, parameter :: psb_mdata_size_=20
integer, parameter :: psb_desc_asb_=3099 integer, parameter :: psb_desc_asb_=3099
integer, parameter :: psb_desc_bld_=psb_desc_asb_+1 integer, parameter :: psb_desc_bld_=psb_desc_asb_+1
integer, parameter :: psb_desc_repl_=3199 integer, parameter :: psb_desc_repl_=3199
integer, parameter :: psb_desc_upd_=psb_desc_bld_+1 integer, parameter :: psb_desc_upd_=psb_desc_bld_+1
integer, parameter :: psb_desc_upd_asb_=psb_desc_upd_+1 integer, parameter :: psb_desc_normal_=3299
integer, parameter :: psb_desc_large_asb_=psb_desc_upd_asb_+1 integer, parameter :: psb_desc_large_=psb_desc_normal_+1
integer, parameter :: psb_desc_large_bld_=psb_desc_large_asb_+1 integer, parameter :: psb_cd_ovl_bld_=3399
integer, parameter :: psb_cd_ovl_asb_=psb_cd_ovl_bld_+1
integer, parameter :: nbits=14 integer, parameter :: nbits=14
integer, parameter :: hashsize=2**nbits, hashmask=hashsize-1 integer, parameter :: hashsize=2**nbits, hashmask=hashsize-1
integer, parameter :: psb_default_large_threshold=4*1024*1024 ! to be reviewed integer, parameter :: psb_default_large_threshold=4*1024*1024 ! to be reviewed

93
base/modules/psb_desc_type.f90
Unescape Escape View File

@ -111,7 +111,7 @@ contains
logical function psb_is_large_desc(desc) logical function psb_is_large_desc(desc)
type(psb_desc_type), intent(in) :: desc type(psb_desc_type), intent(in) :: desc
psb_is_large_desc = psb_is_large_dec(psb_cd_get_dectype(desc)) psb_is_large_desc =(psb_desc_large_==psb_cd_get_size(desc))
end function psb_is_large_desc end function psb_is_large_desc
@ -122,12 +122,6 @@ contains
end function psb_is_upd_desc end function psb_is_upd_desc
logical function psb_is_asb_upd_desc(desc)
type(psb_desc_type), intent(in) :: desc
psb_is_asb_upd_desc = psb_is_asb_upd_dec(psb_cd_get_dectype(desc))
end function psb_is_asb_upd_desc
logical function psb_is_asb_desc(desc) logical function psb_is_asb_desc(desc)
type(psb_desc_type), intent(in) :: desc type(psb_desc_type), intent(in) :: desc
@ -141,16 +135,14 @@ contains
integer :: dectype integer :: dectype
psb_is_ok_dec = ((dectype == psb_desc_asb_).or.(dectype == psb_desc_bld_).or.& psb_is_ok_dec = ((dectype == psb_desc_asb_).or.(dectype == psb_desc_bld_).or.&
&(dectype == psb_desc_upd_).or.(dectype== psb_desc_upd_asb_).or.& &(dectype == psb_desc_upd_).or.&
&(dectype == psb_desc_large_asb_).or.(dectype == psb_desc_large_bld_).or.&
&(dectype== psb_desc_repl_)) &(dectype== psb_desc_repl_))
end function psb_is_ok_dec end function psb_is_ok_dec
logical function psb_is_bld_dec(dectype) logical function psb_is_bld_dec(dectype)
integer :: dectype integer :: dectype
psb_is_bld_dec = (dectype == psb_desc_bld_)& psb_is_bld_dec = (dectype == psb_desc_bld_)
& .or.(dectype == psb_desc_large_bld_)
end function psb_is_bld_dec end function psb_is_bld_dec
logical function psb_is_upd_dec(dectype) logical function psb_is_upd_dec(dectype)
@ -160,18 +152,11 @@ contains
end function psb_is_upd_dec end function psb_is_upd_dec
logical function psb_is_asb_upd_dec(dectype)
integer :: dectype
psb_is_asb_upd_dec = (dectype == psb_desc_upd_asb_)
end function psb_is_asb_upd_dec
logical function psb_is_asb_dec(dectype) logical function psb_is_asb_dec(dectype)
integer :: dectype integer :: dectype
psb_is_asb_dec = (dectype == psb_desc_asb_)& psb_is_asb_dec = (dectype == psb_desc_asb_).or.&
& .or.(dectype == psb_desc_large_asb_).or.&
& (dectype== psb_desc_repl_) & (dectype== psb_desc_repl_)
end function psb_is_asb_dec end function psb_is_asb_dec
@ -213,19 +198,79 @@ contains
psb_cd_get_dectype = desc%matrix_data(psb_dec_type_) psb_cd_get_dectype = desc%matrix_data(psb_dec_type_)
end function psb_cd_get_dectype end function psb_cd_get_dectype
integer function psb_cd_get_size(desc)
type(psb_desc_type), intent(in) :: desc
psb_cd_get_size = desc%matrix_data(psb_desc_size_)
end function psb_cd_get_size
integer function psb_cd_get_mpic(desc) integer function psb_cd_get_mpic(desc)
type(psb_desc_type), intent(in) :: desc type(psb_desc_type), intent(in) :: desc
psb_cd_get_mpic = desc%matrix_data(psb_mpi_c_) psb_cd_get_mpic = desc%matrix_data(psb_mpi_c_)
end function psb_cd_get_mpic end function psb_cd_get_mpic
logical function psb_is_large_dec(dectype)
integer :: dectype
psb_is_large_dec = (dectype == psb_desc_large_asb_)& subroutine psb_cd_set_bld(desc,info)
& .or.(dectype == psb_desc_large_bld_) !
! Change state of a descriptor into BUILD.
! If the descriptor is LARGE, check the AVL search tree
! and initialize it if necessary.
!
use psb_const_mod
use psb_error_mod
use psb_penv_mod
implicit none
type(psb_desc_type), intent(inout) :: desc
integer :: info
!locals
integer :: np,me,ictxt, isz, err_act,idx,gidx,lidx
logical, parameter :: debug=.false.,debugprt=.false.
character(len=20) :: name, char_err
if (debug) write(0,*) me,'Entered CDCPY'
if (psb_get_errstatus() /= 0) return
info = 0
call psb_erractionsave(err_act)
name = 'psb_cd_set_bld'
ictxt = psb_cd_get_context(desc)
! check on blacs grid
call psb_info(ictxt, me, np)
if (debug) write(0,*) me,'Entered CDCPY'
if (psb_is_large_desc(desc)) then
if (.not.allocated(desc%ptree)) then
allocate(desc%ptree(2),stat=info)
if (info /= 0) then
info=4000
goto 9999
endif
call InitPairSearchTree(desc%ptree,info)
do idx=1, psb_cd_get_local_cols(desc)
gidx = desc%loc_to_glob(idx)
call SearchInsKeyVal(desc%ptree,gidx,idx,lidx,info)
if (lidx /= idx) then
write(0,*) 'Warning from cdset: mismatch in PTREE ',idx,lidx
endif
enddo
end if
end if
desc%matrix_data(psb_dec_type_) = psb_desc_bld_
end function psb_is_large_dec call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == act_ret) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_cd_set_bld
end module psb_descriptor_type end module psb_descriptor_type

2
base/modules/psb_tools_mod.f90
Unescape Escape View File

@ -706,7 +706,7 @@ contains
call psb_sum(ictxt,itmpsz) call psb_sum(ictxt,itmpsz)
nlp=0 nlp=0
do i=0, me-1 do i=0, me-1
nlp = nlp + itmpsz(me) nlp = nlp + itmpsz(i)
end do end do
call psb_cd_inloc((/(i,i=nlp+1,nlp+nl)/),ictxt,desc_a,info) call psb_cd_inloc((/(i,i=nlp+1,nlp+nl)/),ictxt,desc_a,info)

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

@ -56,7 +56,7 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info)
Integer :: counter,i,j,np,me,loc_row,err,& Integer :: counter,i,j,np,me,loc_row,err,&
& loc_col,nprocs,n,itmpov, k,glx,gidx,gle,& & loc_col,nprocs,n,itmpov, k,glx,gidx,gle,&
& l_ov_ix,l_ov_el,idx, flag_, err_act,m & l_ov_ix,l_ov_el,idx, flag_, err_act,m
integer :: int_err(5),exch(2) integer :: int_err(5),exch(3)
Integer, allocatable :: temp_ovrlap(:), ov_idx(:),ov_el(:),tmpgidx(:,:) Integer, allocatable :: temp_ovrlap(:), ov_idx(:),ov_el(:),tmpgidx(:,:)
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
character(len=20) :: name character(len=20) :: name
@ -64,16 +64,16 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info)
if(psb_get_errstatus() /= 0) return if(psb_get_errstatus() /= 0) return
info=0 info=0
err=0 err=0
name = 'psb_cdalv' name = 'psb_cd_inloc'
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (debug) write(*,*) 'psb_cdall: ',np,me if (debug) write(*,*) 'psb_cdall: ',np,me
loc_row = size(v) loc_row = size(v)
m = loc_row m = loc_row
call psb_sum(ictxt,m) call psb_sum(ictxt,m)
n = m n = m
!... check m and n parameters.... !... check m and n parameters....
if (m < 1) then if (m < 1) then
@ -90,6 +90,26 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info)
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
end if end if
if (me == psb_root_) then
exch(1)=m
exch(2)=n
exch(3)=psb_cd_get_large_threshold()
call psb_bcast(ictxt,exch(1:3),root=psb_root_)
else
call psb_bcast(ictxt,exch(1:3),root=psb_root_)
if (exch(1) /= m) then
err=550
int_err(1)=1
call psb_errpush(err,name,int_err)
goto 9999
else if (exch(2) /= n) then
err=550
int_err(1)=2
call psb_errpush(err,name,int_err)
goto 9999
endif
call psb_cd_set_large_threshold(exch(3))
endif
if (debug) write(*,*) 'psb_cdall: doing global checks' if (debug) write(*,*) 'psb_cdall: doing global checks'
allocate(tmpgidx(m,2),stat=info) allocate(tmpgidx(m,2),stat=info)
@ -98,19 +118,31 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info)
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
end if end if
tmpgidx=0 tmpgidx=0
flag_=1
do i=1,loc_row do i=1,loc_row
if ((v(i)<1).or.(v(i)>m)) then if ((v(i)<1).or.(v(i)>m)) then
info = 551 info = 551
int_err(1) = i
int_err(2) = v(i)
int_err(3) = loc_row
int_err(4) = m
else else
tmpgidx(v(i),1) = me tmpgidx(v(i),1) = me+flag_
tmpgidx(v(i),2) = 1 tmpgidx(v(i),2) = 1
endif endif
end do end do
call psb_amx(ictxt,tmpgidx) call psb_amx(ictxt,tmpgidx)
if (count(tmpgidx(:,2) == 0)>0) then if (info ==0) then
int_err(1) = count(tmpgidx(:,2) == 0)
int_err(2) = m
if (int_err(1)>0) then
info = 552 info = 552
end if end if
end if
if (info /= 0) then if (info /= 0) then
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
@ -120,16 +152,17 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info)
call psb_nullify_desc(desc_a) call psb_nullify_desc(desc_a)
flag_=0
!count local rows number !count local rows number
! allocate work vector ! allocate work vector
if (m > psb_cd_get_large_threshold()) then if (m > psb_cd_get_large_threshold()) then
allocate(desc_a%matrix_data(psb_mdata_size_),& allocate(desc_a%matrix_data(psb_mdata_size_),&
&temp_ovrlap(m),stat=info) &temp_ovrlap(m),stat=info)
desc_a%matrix_data(psb_desc_size_) = psb_desc_large_
else else
allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),& allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),&
&temp_ovrlap(m),stat=info) &temp_ovrlap(m),stat=info)
desc_a%matrix_data(psb_desc_size_) = psb_desc_normal_
end if end if
if (info /= 0) then if (info /= 0) then
info=2025 info=2025
@ -145,7 +178,6 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info)
temp_ovrlap(:) = -1 temp_ovrlap(:) = -1
if (m > psb_cd_get_large_threshold()) then if (m > psb_cd_get_large_threshold()) then
desc_a%matrix_data(psb_dec_type_) = psb_desc_large_bld_
do i=1,m do i=1,m
@ -210,7 +242,6 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info)
else else
desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_
do i=1,m do i=1,m
if (((tmpgidx(i,1)-flag_) > np-1).or.((tmpgidx(i,1)-flag_) < 0)) then if (((tmpgidx(i,1)-flag_) > np-1).or.((tmpgidx(i,1)-flag_) < 0)) then
@ -327,12 +358,13 @@ subroutine psb_cd_inloc(v, ictxt, desc_a, info)
! 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
desc_a%matrix_data(psb_n_col_) = loc_row desc_a%matrix_data(psb_n_col_) = loc_row
call psb_cd_set_bld(desc_a,info)
allocate(desc_a%halo_index(1),stat=info) call psb_realloc(1,desc_a%halo_index, info)
if (info /= 0) then if (info /= no_err) then
info=4000 info=2025
call psb_errpush(info,name) call psb_errpush(err,name,a_err='psb_realloc')
goto 9999 Goto 9999
end if end if
desc_a%halo_index(:) = -1 desc_a%halo_index(:) = -1

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

@ -57,11 +57,11 @@ subroutine psb_cdals(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, mth
integer :: int_err(5),exch(2) integer :: int_err(5),exch(3)
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.
character(len=20) :: name, char_err character(len=20) :: name
if(psb_get_errstatus() /= 0) return if(psb_get_errstatus() /= 0) return
info=0 info=0
@ -96,9 +96,10 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info)
if (me == psb_root_) then if (me == psb_root_) then
exch(1)=m exch(1)=m
exch(2)=n exch(2)=n
call psb_bcast(ictxt,exch(1:2),root=psb_root_) exch(3)=psb_cd_get_large_threshold()
call psb_bcast(ictxt,exch(1:3),root=psb_root_)
else else
call psb_bcast(ictxt,exch(1:2),root=psb_root_) call psb_bcast(ictxt,exch(1:3),root=psb_root_)
if (exch(1) /= m) then if (exch(1) /= m) then
err=550 err=550
int_err(1)=1 int_err(1)=1
@ -110,15 +111,23 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info)
call psb_errpush(err,name,int_err) call psb_errpush(err,name,int_err)
goto 9999 goto 9999
endif endif
call psb_cd_set_large_threshold(exch(3))
endif endif
call psb_nullify_desc(desc_a) call psb_nullify_desc(desc_a)
!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)
desc_a%matrix_data(psb_desc_size_) = psb_desc_large_
else
allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),&
& temp_ovrlap(m),prc_v(np),stat=info)
desc_a%matrix_data(psb_desc_size_) = psb_desc_normal_
end if
if (info /= 0) then
info=2025 info=2025
err=info err=info
int_err(1)=m int_err(1)=m
@ -131,6 +140,22 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info)
counter = 0 counter = 0
itmpov = 0 itmpov = 0
temp_ovrlap(:) = -1 temp_ovrlap(:) = -1
if ( m >psb_cd_get_large_threshold()) then
loc_col = (m+np-1)/np
allocate(desc_a%loc_to_glob(loc_col), desc_a%lprm(1),&
& desc_a%ptree(2),stat=info)
if (info == 0) call InitPairSearchTree(desc_a%ptree,info)
if (info /= 0) then
info=2025
int_err(1)=loc_col
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
! set LOC_TO_GLOB array to all "-1" values
desc_a%lprm(1) = 0
desc_a%loc_to_glob(:) = -1
k = 0
do i=1,m do i=1,m
if (info == 0) then if (info == 0) then
call parts(i,m,np,prc_v,nprocs) call parts(i,m,np,prc_v,nprocs)
@ -164,29 +189,103 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info)
end if end if
end do end do
endif endif
desc_a%glob_to_loc(i) = -(np+prc_v(1)+1)
j=1 j=1
do do
if (j > nprocs) exit if (j > nprocs) exit
if (prc_v(j) == me) exit if (prc_v(j) == me) exit
j=j+1 j=j+1
enddo enddo
if (j <= nprocs) then if (j <= nprocs) then
if (prc_v(j) == me) then if (prc_v(j) == me) then
! this point belongs to me ! this point belongs to me
counter=counter+1 k = k + 1
desc_a%glob_to_loc(i) = counter 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 if (nprocs > 1) then
if ((itmpov+2+nprocs) > size(temp_ovrlap)) then call psb_check_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-1)
ns = max(itmpov+2+nprocs,int(1.25*size(temp_ovrlap)))
call psb_realloc(ns,temp_ovrlap,info,pad=-1)
if (info /= 0) then if (info /= 0) then
info=2025 info=4010
int_err(1)=m 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
end if
enddo
if (info /= 0) then
info=4000
call psb_errpush(info,name)
goto 9999
endif
loc_row = k
else
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 err=info
call psb_errpush(err,name,int_err) call psb_errpush(err,name,int_err)
goto 9999 goto 9999
end if 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 end if
itmpov = itmpov + 1 itmpov = itmpov + 1
temp_ovrlap(itmpov) = i temp_ovrlap(itmpov) = i
@ -199,8 +298,29 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info)
end if end if
endif endif
enddo enddo
! estimate local cols number
loc_row=counter 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
! 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
@ -227,9 +347,8 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info)
allocate(ov_idx(l_ov_ix),ov_el(l_ov_el), stat=info) allocate(ov_idx(l_ov_ix),ov_el(l_ov_el), stat=info)
if (info /= no_err) then if (info /= no_err) then
info=4010 info=4010
char_err='psb_realloc'
err=info err=info
call psb_errpush(err,name,a_err=char_err) call psb_errpush(err,name,a_err='psb_realloc')
goto 9999 goto 9999
end if end if
@ -260,51 +379,32 @@ subroutine psb_cdals(m, n, parts, ictxt, desc_a, info)
call psb_transfer(ov_idx,desc_a%ovrlap_index,info) call psb_transfer(ov_idx,desc_a%ovrlap_index,info)
if (info == 0) call psb_transfer(ov_el,desc_a%ovrlap_elem,info) if (info == 0) call psb_transfer(ov_el,desc_a%ovrlap_elem,info)
deallocate(prc_v,temp_ovrlap,stat=info) if (info == 0) deallocate(prc_v,temp_ovrlap,stat=info)
if (info /= no_err) then if (info /= no_err) then
info=4000 info=4000
err=info err=info
call psb_errpush(err,name) call psb_errpush(err,name)
Goto 9999 Goto 9999
endif endif
! estimate local cols number ! At this point overlap_elem is OK.
loc_col=min(2*loc_row,m) desc_a%matrix_data(psb_ovl_state_) = psb_cd_ovl_asb_
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
desc_a%matrix_data(psb_n_col_) = loc_row desc_a%matrix_data(psb_n_col_) = loc_row
call psb_cd_set_bld(desc_a,info)
call psb_realloc(1,desc_a%halo_index, info) call psb_realloc(1,desc_a%halo_index, info)
if (info /= no_err) then if (info /= no_err) then
info=2025 info=2025
char_err='psb_realloc' call psb_errpush(err,name,a_err='psb_realloc')
call psb_errpush(err,name,a_err=char_err)
Goto 9999 Goto 9999
end if end if
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_))

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

@ -58,7 +58,7 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag)
Integer :: counter,i,j,np,me,loc_row,err,& Integer :: counter,i,j,np,me,loc_row,err,&
& loc_col,nprocs,m,n,itmpov, k,glx,gidx,gle,& & loc_col,nprocs,m,n,itmpov, k,glx,gidx,gle,&
& l_ov_ix,l_ov_el,idx, flag_, err_act & l_ov_ix,l_ov_el,idx, flag_, err_act
integer :: int_err(5),exch(2) integer :: int_err(5),exch(3)
Integer, allocatable :: temp_ovrlap(:), ov_idx(:),ov_el(:) Integer, allocatable :: temp_ovrlap(:), ov_idx(:),ov_el(:)
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
character(len=20) :: name character(len=20) :: name
@ -93,28 +93,26 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag)
goto 9999 goto 9999
end if end if
if (debug) write(*,*) 'psb_cdall: doing global checks'
!global check on m and n parameters
if (me == psb_root_) then if (me == psb_root_) then
exch(1)=m exch(1)=m
exch(2)=n exch(2)=n
call psb_bcast(ictxt,exch(1:2),root=psb_root_) exch(3)=psb_cd_get_large_threshold()
call psb_bcast(ictxt,exch(1:3),root=psb_root_)
else else
call psb_bcast(ictxt,exch(1:2),root=psb_root_) call psb_bcast(ictxt,exch(1:3),root=psb_root_)
if (exch(1) /= m) then if (exch(1) /= m) then
info=550 err=550
int_err(1)=1 int_err(1)=1
call psb_errpush(err,name,int_err)
goto 9999
else if (exch(2) /= n) then else if (exch(2) /= n) then
info=550 err=550
int_err(1)=2 int_err(1)=2
endif call psb_errpush(err,name,int_err)
endif
if (info /= 0) then
call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
endif endif
call psb_cd_set_large_threshold(exch(3))
endif
call psb_nullify_desc(desc_a) call psb_nullify_desc(desc_a)
@ -136,9 +134,11 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag)
if (m > psb_cd_get_large_threshold()) then if (m > psb_cd_get_large_threshold()) then
allocate(desc_a%matrix_data(psb_mdata_size_),& allocate(desc_a%matrix_data(psb_mdata_size_),&
&temp_ovrlap(m),stat=info) &temp_ovrlap(m),stat=info)
desc_a%matrix_data(psb_desc_size_) = psb_desc_large_
else else
allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),& allocate(desc_a%glob_to_loc(m),desc_a%matrix_data(psb_mdata_size_),&
&temp_ovrlap(m),stat=info) &temp_ovrlap(m),stat=info)
desc_a%matrix_data(psb_desc_size_) = psb_desc_normal_
end if end if
if (info /= 0) then if (info /= 0) then
info=2025 info=2025
@ -154,7 +154,6 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag)
temp_ovrlap(:) = -1 temp_ovrlap(:) = -1
if ( m >psb_cd_get_large_threshold()) then if ( m >psb_cd_get_large_threshold()) then
desc_a%matrix_data(psb_dec_type_) = psb_desc_large_bld_
do i=1,m do i=1,m
@ -219,7 +218,6 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag)
else else
desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_
do i=1,m do i=1,m
if (((v(i)-flag_) > np-1).or.((v(i)-flag_) < 0)) then if (((v(i)-flag_) > np-1).or.((v(i)-flag_) < 0)) then
@ -336,12 +334,13 @@ subroutine psb_cdalv(v, ictxt, desc_a, info, flag)
! 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
desc_a%matrix_data(psb_n_col_) = loc_row desc_a%matrix_data(psb_n_col_) = loc_row
call psb_cd_set_bld(desc_a,info)
allocate(desc_a%halo_index(1),stat=info) call psb_realloc(1,desc_a%halo_index, info)
if (info /= 0) then if (info /= no_err) then
info=4000 info=2025
call psb_errpush(info,name) call psb_errpush(err,name,a_err='psb_realloc')
goto 9999 Goto 9999
end if end if
desc_a%halo_index(:) = -1 desc_a%halo_index(:) = -1

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

@ -128,21 +128,14 @@ subroutine psb_cdasb(desc_a,info)
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (psb_is_large_dec(dectype) ) then
desc_a%matrix_data(psb_dec_type_) = psb_desc_large_asb_
!!$ write(0,*) 'Done large dec asmbly',desc_a%matrix_data(psb_dec_type_),&
!!$ & psb_desc_large_asb_,psb_is_asb_dec(desc_a%matrix_data(psb_dec_type_))
else
! Ok, register into MATRIX_DATA & free temporary work areas ! Ok, register into MATRIX_DATA & free temporary work areas
desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_ desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_
endif
else else
info = 600 info = 600
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
if (debug) write(0,*) 'dectype 2 :',dectype,psb_desc_bld_,& if (debug) write(0,*) 'dectype 2 :',psb_cd_get_dectype(desc_a),&
&psb_desc_asb_,psb_desc_upd_ &psb_desc_bld_,psb_desc_asb_,psb_desc_upd_
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)

3
base/tools/psb_cdrep.f90
Unescape Escape View File

@ -184,6 +184,9 @@ subroutine psb_cdrep(m, ictxt, desc_a, info)
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
endif endif
! If the index space is replicated there's no point in having
! the AVL tree structure....
desc_a%matrix_data(psb_desc_size_) = psb_desc_normal_
desc_a%matrix_data(psb_m_) = m desc_a%matrix_data(psb_m_) = m

30
base/tools/psb_dcdovr.f90
Unescape Escape View File

@ -156,36 +156,18 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info)
l_tmp_halo = novr*(3*Size(desc_a%halo_index)) l_tmp_halo = novr*(3*Size(desc_a%halo_index))
if (psb_is_large_desc(desc_a)) then if (psb_is_large_desc(desc_a)) then
desc_ov%matrix_data(psb_dec_type_) = psb_desc_large_bld_ desc_ov%matrix_data(psb_desc_size_) = psb_desc_large_
else else
desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_ desc_ov%matrix_data(psb_desc_size_) = psb_desc_normal_
end if
If(debug) then
Write(0,*)'Start cdovrbld',me,lworks,lworkr
call psb_barrier(ictxt)
endif
if (.false.) then
!
! The real work goes on in here....
!
Call psb_cdovrbld(novr,desc_ov,desc_a,a,&
& l_tmp_halo,l_tmp_ovr_idx,lworks,lworkr,info)
if (info /= 0) then
info=4010
ch_err='psb_cdovrbld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if end if
call psb_cd_set_bld(desc_ov,info)
!!$ desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_
If(debug) then If(debug) then
Write(0,*)'Done cdovrbld',me,lworks,lworkr Write(0,*)'Start cdovrbld',me,lworks,lworkr
call psb_barrier(ictxt) call psb_barrier(ictxt)
endif endif
else
Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info)
if (info /= 0) then if (info /= 0) then
@ -692,8 +674,6 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info)
goto 9999 goto 9999
end if end if
end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

30
base/tools/psb_zcdovr.f90
Unescape Escape View File

@ -155,36 +155,18 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info)
l_tmp_halo = novr*(3*Size(desc_a%halo_index)) l_tmp_halo = novr*(3*Size(desc_a%halo_index))
if (psb_is_large_desc(desc_a)) then if (psb_is_large_desc(desc_a)) then
desc_ov%matrix_data(psb_dec_type_) = psb_desc_large_bld_ desc_ov%matrix_data(psb_desc_size_) = psb_desc_large_
else else
desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_ desc_ov%matrix_data(psb_desc_size_) = psb_desc_normal_
end if
If(debug) then
Write(0,*)'Start cdovrbld',me,lworks,lworkr
call psb_barrier(ictxt)
endif
if (.false.) then
!
! The real work goes on in here....
!
Call psb_cdovrbld(novr,desc_ov,desc_a,a,&
& l_tmp_halo,l_tmp_ovr_idx,lworks,lworkr,info)
if (info /= 0) then
info=4010
ch_err='psb_cdovrbld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if end if
call psb_cd_set_bld(desc_ov,info)
!!$ desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_
If(debug) then If(debug) then
Write(0,*)'Done cdovrbld',me,lworks,lworkr Write(0,*)'Start cdovrbld',me,lworks,lworkr
call psb_barrier(ictxt) call psb_barrier(ictxt)
endif endif
else
Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info)
if (info /= 0) then if (info /= 0) then
@ -691,8 +673,6 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info)
goto 9999 goto 9999
end if end if
end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

Write Preview
Loading…
Cancel
Save