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

Created new internal to set bld status of descriptor.

Browse Source 
Fixed glob_to_loc actions (and their description).
psblas3-type-indexed
Salvatore Filippone 18 years ago
parent 36417f6f21
commit bcb22d2195
12 changed files with 6747 additions and 6589 deletions
Show Stats Download Patch File Download Diff File

22
docs/pdf/toolsrout.tex
Unescape Escape View File

@ -777,8 +777,8 @@ Specified as: Integer scalar.\\
%
\subroutine{psb\_glob\_to\_loc}{Global to local indices convertion}
\syntax{call psb\_glob\_to\_loc}{x, y, desc\_a, info, iact}
\syntax*{call psb\_glob\_to\_loc}{x, desc\_a, info, iact}
\syntax{call psb\_glob\_to\_loc}{x, y, desc\_a, info, iact,owned}
\syntax*{call psb\_glob\_to\_loc}{x, desc\_a, info, iact,owned}
\begin{description}
\item[\bf On Entry]
@ -793,7 +793,14 @@ Specified as: a structured data of type \descdata.
\item[iact] specifies action to be taken in case of range errors.
Scope: {\bf global} \\
Type: {\bf optional}\\
Specified as: a character variable \verb|E|, \verb|W| or \verb|A|.
Specified as: a character variable \verb|I|gnore, \verb|W|arning or
\verb|A|bort, default \verb|I|gnore.
\item[owned] Specfies valid range of input
Scope: {\bf global} \\
Type: {\bf optional}\\
If true, then only indices strictly owned by the current process are
considered valid, if false then halo indices are also
accepted. Default: false.
\end{description}
\begin{description}
@ -803,7 +810,7 @@ Specified as: a character variable \verb|E|, \verb|W| or \verb|A|.
Scope: {\bf global} \\
Type: {\bf required}\\
Specified as: a rank one integer array.
\item[y] If $y$ is not present,
\item[y] If $y$ is present,
then $y$ is overwritten with the translated integer indices, and $x$
is left unchanged.
Scope: {\bf global} \\
@ -815,6 +822,13 @@ Type: {\bf required}\\
Specified as: an integer variable.
\end{description}
\section*{Notes}
\begin{enumerate}
\item If an input index is out of range, then the corresponding output
index is set to a negative number;
\item The default \verb|I|gnore means that the negative output is the
only action taken on an out-of-range input.
\end{enumerate}
%

11261
docs/userguide.pdf
View File

File diff suppressed because one or more lines are too long

2
src/modules/Makefile
Unescape Escape View File

@ -21,7 +21,7 @@ psb_spmat_type.o : psb_realloc_mod.o psb_const_mod.o psb_string_mod.o
psb_error_mod.o: psb_const_mod.o
psb_penv_mod.o: psb_const_mod.o psb_error_mod.o
psi_mod.o: psb_penv_mod.o psb_error_mod.o psb_desc_type.o
psb_desc_type.o: psb_const_mod.o
psb_desc_type.o: psb_const_mod.o psb_error_mod.o psb_penv_mod.o
psb_check_mod.o: psb_desc_type.o
psb_methd_mod.o: psb_serial_mod.o psb_desc_type.o psb_prec_type.o
psb_tools_mod.o: psb_spmat_type.o psb_desc_type.o psi_mod.o

59
src/modules/psb_desc_type.f90
Unescape Escape View File

@ -227,5 +227,64 @@ contains
end function psb_is_large_dec
subroutine psb_cd_set_bld(desc,info)
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_cdcpy'
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
desc%matrix_data(psb_dec_type_) = psb_desc_large_bld_
else
desc%matrix_data(psb_dec_type_) = psb_desc_bld_
end if
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

2
src/modules/psb_error_mod.f90
Unescape Escape View File

@ -351,6 +351,8 @@ contains
write (0,'("indices in input array are not within problem dimension ",2(i0,2x))')i_e_d(1:2)
case(150)
write (0,'("indices in input array are not belonging to the calling process ",i0)')i_e_d(1)
case(151)
write (0,'("indices in input array are not belonging to the calling process ")')
case(290)
write (0,'("To call this routine you must first call psb_geall on the same matrix")')
case(295)

6
src/modules/psb_tools_mod.f90
Unescape Escape View File

@ -557,20 +557,22 @@ Module psb_tools_mod
interface psb_glob_to_loc
subroutine psb_glob_to_loc2(x,y,desc_a,info,iact)
subroutine psb_glob_to_loc2(x,y,desc_a,info,iact,owned)
use psb_descriptor_type
type(psb_desc_type), intent(in) :: desc_a
integer,intent(in) :: x(:)
integer,intent(out) :: y(:)
integer, intent(out) :: info
character, intent(in), optional :: iact
logical, intent(in), optional :: owned
end subroutine psb_glob_to_loc2
subroutine psb_glob_to_loc(x,desc_a,info,iact)
subroutine psb_glob_to_loc(x,desc_a,info,iact,owned)
use psb_descriptor_type
type(psb_desc_type), intent(in) :: desc_a
integer,intent(inout) :: x(:)
integer, intent(out) :: info
character, intent(in), optional :: iact
logical, intent(in), optional :: owned
end subroutine psb_glob_to_loc
end interface

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

@ -387,6 +387,7 @@ subroutine psb_cdall(m, n, parts, ictxt, desc_a, info)
! set fields in desc_a%MATRIX_DATA....
desc_a%matrix_data(psb_n_row_) = 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)
if (info /= no_err) then

10
src/tools/psb_cdasb.f90
Unescape Escape View File

@ -130,6 +130,16 @@ subroutine psb_cdasb(desc_a,info)
end if
if (psb_is_large_dec(dectype) ) then
if (allocated(desc_a%ptree)) then
call FreePairSearchTree(desc_a%ptree)
deallocate(desc_a%ptree,stat=info)
if (info /= 0) then
info=2059
call psb_errpush(info,name)
goto 9999
end if
end if
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_))

29
src/tools/psb_dcdovr.f90
Unescape Escape View File

@ -157,36 +157,13 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info)
l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1)
l_tmp_halo = novr*(3*Size(desc_a%halo_index))
if (psb_is_large_desc(desc_a)) then
desc_ov%matrix_data(psb_dec_type_) = psb_desc_large_bld_
else
desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_
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
call psb_cd_set_bld(desc_ov,info)
If(debug) then
Write(0,*)'Done cdovrbld',me,lworks,lworkr
Write(0,*)'Start cdovrbld',me,lworks,lworkr
call psb_barrier(ictxt)
endif
else
Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info)
@ -358,6 +335,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info)
tmp_ovr_idx(counter_o+2)=gidx
tmp_ovr_idx(counter_o+3)=-1
counter_o=counter_o+3
if (.not.psb_is_large_desc(desc_ov)) then
call psb_check_size((counter_h+3),tmp_halo,info,pad=-1)
if (info /= 0) then
@ -694,7 +672,6 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info)
goto 9999
end if
end if
call psb_erractionrestore(err_act)
return

197
src/tools/psb_glob_to_loc.f90
Unescape Escape View File

@ -40,7 +40,7 @@
! info - integer. Eventually returns an error code.
! iact - integer(optional). A character defining the behaviour of this subroutine when is found an index not belonging to the calling process
!
subroutine psb_glob_to_loc2(x,y,desc_a,info,iact)
subroutine psb_glob_to_loc2(x,y,desc_a,info,iact,owned)
use psb_descriptor_type
use psb_const_mod
@ -55,6 +55,7 @@ subroutine psb_glob_to_loc2(x,y,desc_a,info,iact)
integer, intent(in) :: x(:)
integer, intent(out) :: y(:), info
character, intent(in), optional :: iact
logical, intent(in), optional :: owned
!....locals....
integer :: n, i, tmp
@ -62,40 +63,51 @@ subroutine psb_glob_to_loc2(x,y,desc_a,info,iact)
integer :: int_err(5), err_act
real(kind(1.d0)) :: real_val
integer, parameter :: zero=0
logical :: owned_
character(len=20) :: name
integer :: ictxt, iam, np
if(psb_get_errstatus() /= 0) return
info=0
name = 'glob_to_loc'
ictxt = psb_cd_get_context(desc_a)
call psb_info(ictxt,iam,np)
call psb_erractionsave(err_act)
if (present(iact)) then
act=iact
else
act='A'
act='I'
endif
act = toupper(act)
if (present(owned)) then
owned_ = owned
else
owned_ = .false.
end if
int_err=0
real_val = 0.d0
n = size(x)
call psi_idx_cnv(n,x,y,desc_a,info)
call psi_idx_cnv(n,x,y,desc_a,info,owned=owned_)
select case(act)
case('E','I')
call psb_erractionrestore(err_act)
return
case('I')
case('W')
if ((info /= 0).or.(count(y(1:n)<0) >0)) then
write(0,'("Error ",i5," in subroutine glob_to_loc")') info
if (count(y(1:n)<0) >0) then
write(0,'("Out of bounds input in subroutine glob_to_loc")')
end if
case('A')
if ((info /= 0).or.(count(y(1:n)<0) >0)) then
case('E','A')
if (count(y(1:n)<0) >0) then
info = 151
end if
end select
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
end if
end select
call psb_erractionrestore(err_act)
return
@ -153,7 +165,7 @@ end subroutine psb_glob_to_loc2
! info - integer. Eventually returns an error code.
! iact - integer(optional). A character defining the behaviour of this subroutine when is found an index not belonging to the calling process
!
subroutine psb_glob_to_loc(x,desc_a,info,iact)
subroutine psb_glob_to_loc(x,desc_a,info,iact,owned)
use psb_penv_mod
use psb_descriptor_type
@ -168,50 +180,57 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact)
integer, intent(inout) :: x(:)
integer, intent(out) :: info
character, intent(in), optional :: iact
logical, intent(in), optional :: owned
!....locals....
integer :: n, i, tmp, nk, key, idx, ih, nh, lb, ub, lm
character :: act
integer :: int_err(5), err_act, dectype
integer :: int_err(5), err_act
real(kind(1.d0)) :: real_val, t0, t1,t2
integer, parameter :: zero=0
logical :: owned_
character(len=20) :: name
integer :: ictxt, iam, np
if(psb_get_errstatus() /= 0) return
info=0
name = 'glob_to_loc'
ictxt = desc_a%matrix_data(psb_ctxt_)
ictxt = psb_cd_get_context(desc_a)
call psb_info(ictxt,iam,np)
call psb_erractionsave(err_act)
dectype = desc_a%matrix_data(psb_dec_type_)
if (present(iact)) then
act=iact
else
act='A'
act='I'
endif
act = toupper(act)
if (present(owned)) then
owned_ = owned
else
owned_ = .false.
end if
n = size(x)
call psi_idx_cnv(n,x,desc_a,info)
call psi_idx_cnv(n,x,desc_a,info,owned=owned_)
select case(act)
case('E','I')
call psb_erractionrestore(err_act)
return
case('I')
case('W')
if ((info /= 0).or.(count(x(1:n)<0) >0)) then
write(0,'("Error ",i5," in subroutine glob_to_loc")') info
if (count(x(1:n)<0) >0) then
write(0,'("Out of bounds input in subroutine glob_to_loc")')
end if
case('E','A')
if (count(x(1:n)<0) >0) then
info = 151
end if
case('A')
if ((info /= 0).or.(count(x(1:n)<0) >0)) then
write(0,*) count(x(1:n)<0)
end select
if (info /= 0) then
call psb_errpush(info,name)
goto 9999
end if
end select
call psb_erractionrestore(err_act)
return
@ -226,69 +245,69 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact)
end if
return
contains
subroutine inlbsrch(ipos,key,n,v)
implicit none
integer ipos, key, n
integer v(n)
integer lb, ub, m
lb = 1
ub = n
ipos = -1
do
if (lb > ub) return
m = (lb+ub)/2
if (key.eq.v(m)) then
ipos = m
return
else if (key.lt.v(m)) then
ub = m-1
else
lb = m + 1
end if
enddo
return
end subroutine inlbsrch
subroutine inner_cnv(n,x,hashsize,hashmask,hashv,glb_lc)
integer :: n, hashsize,hashmask,x(:), hashv(0:),glb_lc(:,:)
integer :: i, ih, key, idx,nh,tmp,lb,ub,lm
do i=1, n
key = x(i)
ih = iand(key,hashmask)
idx = hashv(ih)
nh = hashv(ih+1) - hashv(ih)
if (nh > 0) then
tmp = -1
lb = idx
ub = idx+nh-1
do
if (lb>ub) exit
lm = (lb+ub)/2
if (key==glb_lc(lm,1)) then
tmp = lm
exit
else if (key<glb_lc(lm,1)) then
ub = lm - 1
else
lb = lm + 1
end if
end do
else
tmp = -1
end if
if (tmp > 0) then
x(i) = glb_lc(tmp,2)
else
x(i) = tmp
end if
end do
end subroutine inner_cnv
!!$contains
!!$
!!$ subroutine inlbsrch(ipos,key,n,v)
!!$ implicit none
!!$ integer ipos, key, n
!!$ integer v(n)
!!$
!!$ integer lb, ub, m
!!$
!!$
!!$ lb = 1
!!$ ub = n
!!$ ipos = -1
!!$
!!$ do
!!$ if (lb > ub) return
!!$ m = (lb+ub)/2
!!$ if (key.eq.v(m)) then
!!$ ipos = m
!!$ return
!!$ else if (key.lt.v(m)) then
!!$ ub = m-1
!!$ else
!!$ lb = m + 1
!!$ end if
!!$ enddo
!!$ return
!!$ end subroutine inlbsrch
!!$
!!$ subroutine inner_cnv(n,x,hashsize,hashmask,hashv,glb_lc)
!!$ integer :: n, hashsize,hashmask,x(:), hashv(0:),glb_lc(:,:)
!!$ integer :: i, ih, key, idx,nh,tmp,lb,ub,lm
!!$ do i=1, n
!!$ key = x(i)
!!$ ih = iand(key,hashmask)
!!$ idx = hashv(ih)
!!$ nh = hashv(ih+1) - hashv(ih)
!!$ if (nh > 0) then
!!$ tmp = -1
!!$ lb = idx
!!$ ub = idx+nh-1
!!$ do
!!$ if (lb>ub) exit
!!$ lm = (lb+ub)/2
!!$ if (key==glb_lc(lm,1)) then
!!$ tmp = lm
!!$ exit
!!$ else if (key<glb_lc(lm,1)) then
!!$ ub = lm - 1
!!$ else
!!$ lb = lm + 1
!!$ end if
!!$ end do
!!$ else
!!$ tmp = -1
!!$ end if
!!$ if (tmp > 0) then
!!$ x(i) = glb_lc(tmp,2)
!!$ else
!!$ x(i) = tmp
!!$ end if
!!$ end do
!!$ end subroutine inner_cnv
end subroutine psb_glob_to_loc

8
src/tools/psb_loc_to_glob.f90
Unescape Escape View File

@ -100,12 +100,12 @@ subroutine psb_loc_to_glob2(x,y,desc_a,info,iact)
if (info /= 0) then
select case(act)
case('E')
case('I')
call psb_erractionrestore(err_act)
return
case('W')
write(0,'("Error ",i5," in subroutine glob_to_loc")') info
case('A')
case('E','A')
call psb_errpush(info,name)
goto 9999
end select
@ -223,12 +223,12 @@ subroutine psb_loc_to_glob(x,desc_a,info,iact)
if (info /= 0) then
select case(act)
case('E')
case('I')
call psb_erractionrestore(err_act)
return
case('W')
write(0,'("Error ",i5," in subroutine glob_to_loc")') info
case('A')
case('A','E')
call psb_errpush(info,name)
goto 9999
end select

33
src/tools/psb_zcdovr.f90
Unescape Escape View File

@ -156,37 +156,17 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info)
l_tmp_ovr_idx = novr*(3*Max(2*index_dim,1)+1)
l_tmp_halo = novr*(3*Size(desc_a%halo_index))
if (psb_is_large_desc(desc_a)) then
desc_ov%matrix_data(psb_dec_type_) = psb_desc_large_bld_
else
desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_
end if
call psb_cd_set_bld(desc_ov,info)
!!$ if (psb_is_large_desc(desc_a)) then
!!$ desc_ov%matrix_data(psb_dec_type_) = psb_desc_large_bld_
!!$ else
!!$ desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_
!!$ 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
If(debug) then
Write(0,*)'Done cdovrbld',me,lworks,lworkr
call psb_barrier(ictxt)
endif
else
Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info)
if (info /= 0) then
@ -693,7 +673,6 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info)
goto 9999
end if
end if
call psb_erractionrestore(err_act)
return

Write Preview
Loading…
Cancel
Save