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/modules/psb_gen_block_map_mod.f90

Do not (over)use in-place methods
psblas-testmv
Salvatore Filippone 11 years ago
parent 82ab631ff9
commit 6e450a440c
1 changed files with 333 additions and 11 deletions
Show Stats Download Patch File Download Diff File

344
base/modules/psb_gen_block_map_mod.f90
Unescape Escape View File

@ -230,12 +230,58 @@ contains
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: is, im
integer(psb_ipk_) :: is, im, i
logical :: owned_
info = 0
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%l2gip(idxout(1:im),info,mask,owned)
if (present(mask)) then
if (size(mask) < im) then
info = -1
return
end if
end if
if (present(owned)) then
owned_ = owned
else
owned_ = .false.
end if
if (present(mask)) then
do i=1, im
if (mask(i)) then
if ((1<=idxin(i)).and.(idxin(i) <= idxmap%local_rows)) then
idxout(i) = idxmap%min_glob_row + idxin(i) - 1
else if ((idxmap%local_rows < idxin(i)).and.(idxin(i) <= idxmap%local_cols)&
& .and.(.not.owned_)) then
idxout(i) = idxmap%loc_to_glob(idxin(i)-idxmap%local_rows)
else
idxout(i) = -1
info = -1
end if
end if
end do
else if (.not.present(mask)) then
do i=1, im
if ((1<=idxin(i)).and.(idxin(i) <= idxmap%local_rows)) then
idxout(i) = idxmap%min_glob_row + idxin(i) - 1
else if ((idxmap%local_rows < idxin(i)).and.(idxin(i) <= idxmap%local_cols)&
& .and.(.not.owned_)) then
idxout(i) = idxmap%loc_to_glob(idxin(i)-idxmap%local_rows)
else
idxout(i) = -1
info = -1
end if
end do
end if
if (is > im) then
info = -3
end if
@ -387,6 +433,8 @@ contains
end subroutine block_g2lv1
subroutine block_g2lv2(idxin,idxout,idxmap,info,mask,owned)
use psb_penv_mod
use psb_sort_mod
implicit none
class(psb_gen_block_map), intent(in) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:)
@ -395,12 +443,104 @@ contains
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: is, im
integer(psb_ipk_) :: i, nv, is, ip, lip, im
integer(psb_mpik_) :: ictxt, iam, np
logical :: owned_
info = 0
ictxt = idxmap%get_ctxt()
call psb_info(ictxt,iam,np)
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%g2lip(idxout(1:im),info,mask,owned)
if (present(mask)) then
if (size(mask) < im) then
!!$ write(0,*) 'Block g2l: size of mask', size(mask),size(idx)
info = -1
return
end if
end if
if (present(owned)) then
owned_ = owned
else
owned_ = .false.
end if
if (present(mask)) then
if (idxmap%is_asb()) then
do i=1, im
if (mask(i)) then
if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then
idxout(i) = idxin(i) - idxmap%min_glob_row + 1
else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)&
&.and.(.not.owned_)) then
nv = size(idxmap%srt_l2g,1)
idxout(i) = psb_ibsrch(idxin(i),nv,idxmap%srt_l2g(:,1))
if (idxout(i) > 0) idxout(i) = idxmap%srt_l2g(idxout(i),2)+idxmap%local_rows
else
idxout(i) = -1
end if
end if
end do
else if (idxmap%is_valid()) then
do i=1,im
if (mask(i)) then
if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then
idxout(i) = idxin(i) - idxmap%min_glob_row + 1
else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)&
&.and.(.not.owned_)) then
ip = idxin(i)
call psb_hash_searchkey(ip,lip,idxmap%hash,info)
if (lip > 0) idxout(i) = lip + idxmap%local_rows
else
idxout(i) = -1
end if
end if
end do
else
!!$ write(0,*) 'Block status: invalid ',idxmap%get_state()
idxout(1:im) = -1
info = -1
end if
else if (.not.present(mask)) then
if (idxmap%is_asb()) then
do i=1, im
if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then
idxout(i) = idxin(i) - idxmap%min_glob_row + 1
else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)&
&.and.(.not.owned_)) then
nv = size(idxmap%srt_l2g,1)
idxout(i) = psb_ibsrch(idxin(i),nv,idxmap%srt_l2g(:,1))
if (idxout(i) > 0) idxout(i) = idxmap%srt_l2g(idxout(i),2)+idxmap%local_rows
else
idxout(i) = -1
end if
end do
else if (idxmap%is_valid()) then
do i=1,im
if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then
idxout(i) = idxin(i) - idxmap%min_glob_row + 1
else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)&
&.and.(.not.owned_)) then
ip = idxin(i)
call psb_hash_searchkey(ip,lip,idxmap%hash,info)
if (lip > 0) idxout(i) = lip + idxmap%local_rows
else
idxout(i) = -1
end if
end do
else
!!$ write(0,*) 'Block status: invalid ',idxmap%get_state()
idxout(1:im) = -1
info = -1
end if
end if
if (is > im) info = -3
end subroutine block_g2lv2
@ -647,6 +787,8 @@ contains
end subroutine block_g2lv1_ins
subroutine block_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx)
use psb_realloc_mod
use psb_sort_mod
implicit none
class(psb_gen_block_map), intent(inout) :: idxmap
integer(psb_ipk_), intent(in) :: idxin(:)
@ -655,12 +797,192 @@ contains
logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
integer(psb_ipk_) :: is, im
integer(psb_ipk_) :: i, nv, is, ix, im
integer(psb_ipk_) :: ip, lip, nxt
info = 0
is = size(idxin)
im = min(is,size(idxout))
idxout(1:im) = idxin(1:im)
call idxmap%g2lip_ins(idxout(1:im),info,mask=mask,lidx=lidx)
if (present(mask)) then
if (size(mask) < im) then
info = -1
return
end if
end if
if (present(lidx)) then
if (size(lidx) < im) then
info = -1
return
end if
end if
if (idxmap%is_asb()) then
! State is wrong for this one !
idxout = -1
info = -1
else if (idxmap%is_valid()) then
if (present(lidx)) then
if (present(mask)) then
do i=1, im
if (mask(i)) then
if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then
idxout(i) = idxin(i) - idxmap%min_glob_row + 1
else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then
if (lidx(i) <= idxmap%local_rows) then
info = -5
return
end if
nxt = lidx(i)-idxmap%local_rows
ip = idxin(i)
call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info)
if (info >= 0) then
if (lip == nxt) then
! We have added one item
call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz)
if (info /= 0) then
info = -4
return
end if
idxmap%local_cols = max(lidx(i),idxmap%local_cols)
idxmap%loc_to_glob(nxt) = idxin(i)
end if
info = psb_success_
else
info = -5
return
end if
idxout(i) = lip + idxmap%local_rows
else
idxout(i) = -1
info = -1
end if
end if
end do
else if (.not.present(mask)) then
do i=1, im
if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then
idxout(i) = idxin(i) - idxmap%min_glob_row + 1
else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then
if (lidx(i) <= idxmap%local_rows) then
info = -5
return
end if
nxt = lidx(i)-idxmap%local_rows
ip = idxin(i)
call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info)
if (info >= 0) then
if (lip == nxt) then
! We have added one item
call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz)
if (info /= 0) then
info = -4
return
end if
idxmap%local_cols = max(lidx(i),idxmap%local_cols)
idxmap%loc_to_glob(nxt) = idxin(i)
end if
info = psb_success_
else
info = -5
return
end if
idxout(i) = lip + idxmap%local_rows
else
idxout(i) = -1
info = -1
end if
end do
end if
else if (.not.present(lidx)) then
if (present(mask)) then
do i=1, im
if (mask(i)) then
if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then
idxout(i) = idxin(i) - idxmap%min_glob_row + 1
else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then
nv = idxmap%local_cols-idxmap%local_rows
nxt = nv + 1
ip = idxin(i)
call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info)
if (info >= 0) then
if (lip == nxt) then
! We have added one item
call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz)
if (info /= 0) then
info = -4
return
end if
idxmap%local_cols = nxt + idxmap%local_rows
idxmap%loc_to_glob(nxt) = idxin(i)
end if
info = psb_success_
else
info = -5
return
end if
idxout(i) = lip + idxmap%local_rows
else
idxout(i) = -1
info = -1
end if
end if
end do
else if (.not.present(mask)) then
do i=1, im
if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then
idxout(i) = idxin(i) - idxmap%min_glob_row + 1
else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then
nv = idxmap%local_cols-idxmap%local_rows
nxt = nv + 1
ip = idxin(i)
call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info)
if (info >= 0) then
if (lip == nxt) then
! We have added one item
call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz)
if (info /= 0) then
info = -4
return
end if
idxmap%local_cols = nxt + idxmap%local_rows
idxmap%loc_to_glob(nxt) = idxin(i)
end if
info = psb_success_
else
info = -5
return
end if
idxout(i) = lip + idxmap%local_rows
else
idxout(i) = -1
info = -1
end if
end do
end if
end if
else
idxout = -1
info = -1
end if
if (is > im) then
!!$ write(0,*) 'g2lv2_ins err -3'
info = -3

Write Preview
Loading…
Cancel
Save