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

Simplify G2L

Browse Source
newG2L
Salvatore Filippone 3 years ago
parent 1dc28fb710
commit 6f92b7bfb3
3 changed files with 295 additions and 1399 deletions
Show Stats Download Patch File Download Diff File

883
base/modules/desc/psb_gen_block_map_mod.F90
Unescape Escape View File

@ -82,31 +82,16 @@ module psb_gen_block_map_mod
procedure, pass(idxmap) :: reinit => block_reinit
procedure, nopass :: get_fmt => block_get_fmt
!!$ procedure, pass(idxmap) :: l2gs1 => block_l2gs1
!!$ procedure, pass(idxmap) :: l2gs2 => block_l2gs2
!!$ procedure, pass(idxmap) :: l2gv1 => block_l2gv1
!!$ procedure, pass(idxmap) :: l2gv2 => block_l2gv2
procedure, pass(idxmap) :: ll2gs1 => block_ll2gs1
procedure, pass(idxmap) :: ll2gs2 => block_ll2gs2
procedure, pass(idxmap) :: ll2gv1 => block_ll2gv1
procedure, pass(idxmap) :: ll2gv2 => block_ll2gv2
!!$ procedure, pass(idxmap) :: g2ls1 => block_g2ls1
!!$ procedure, pass(idxmap) :: g2ls2 => block_g2ls2
!!$ procedure, pass(idxmap) :: g2lv1 => block_g2lv1
!!$ procedure, pass(idxmap) :: g2lv2 => block_g2lv2
procedure, pass(idxmap) :: lg2ls1 => block_lg2ls1
procedure, pass(idxmap) :: lg2ls2 => block_lg2ls2
procedure, pass(idxmap) :: lg2lv1 => block_lg2lv1
procedure, pass(idxmap) :: lg2lv2 => block_lg2lv2
!!$ procedure, pass(idxmap) :: g2ls1_ins => block_g2ls1_ins
!!$ procedure, pass(idxmap) :: g2ls2_ins => block_g2ls2_ins
!!$ procedure, pass(idxmap) :: g2lv1_ins => block_g2lv1_ins
!!$ procedure, pass(idxmap) :: g2lv2_ins => block_g2lv2_ins
procedure, pass(idxmap) :: lg2ls1_ins => block_lg2ls1_ins
procedure, pass(idxmap) :: lg2ls2_ins => block_lg2ls2_ins
procedure, pass(idxmap) :: lg2lv1_ins => block_lg2lv1_ins
@ -173,165 +158,6 @@ contains
end subroutine block_free
!!$
!!$ subroutine block_l2gs1(idx,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_gen_block_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: idxv(1)
!!$ info = 0
!!$ if (present(mask)) then
!!$ if (.not.mask) return
!!$ end if
!!$
!!$ idxv(1) = idx
!!$ call idxmap%l2gip(idxv,info,owned=owned)
!!$ idx = idxv(1)
!!$
!!$ end subroutine block_l2gs1
!!$
!!$ subroutine block_l2gs2(idxin,idxout,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_gen_block_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(in) :: idxin
!!$ integer(psb_ipk_), intent(out) :: idxout
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ logical, intent(in), optional :: owned
!!$
!!$ idxout = idxin
!!$ call idxmap%l2gip(idxout,info,mask,owned)
!!$
!!$ end subroutine block_l2gs2
!!$
!!$
!!$ subroutine block_l2gv1(idx,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_gen_block_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: i
!!$ logical :: owned_
!!$ info = 0
!!$
!!$ if (present(mask)) then
!!$ if (size(mask) < size(idx)) 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, size(idx)
!!$ if (mask(i)) then
!!$ if ((1<=idx(i)).and.(idx(i) <= idxmap%local_rows)) then
!!$ idx(i) = idxmap%min_glob_row + idx(i) - 1
!!$ else if ((idxmap%local_rows < idx(i)).and.(idx(i) <= idxmap%local_cols)&
!!$ & .and.(.not.owned_)) then
!!$ idx(i) = idxmap%loc_to_glob(idx(i)-idxmap%local_rows)
!!$ else
!!$ idx(i) = -1
!!$ info = -1
!!$ end if
!!$ end if
!!$ end do
!!$
!!$ else if (.not.present(mask)) then
!!$
!!$ do i=1, size(idx)
!!$ if ((1<=idx(i)).and.(idx(i) <= idxmap%local_rows)) then
!!$ idx(i) = idxmap%min_glob_row + idx(i) - 1
!!$ else if ((idxmap%local_rows < idx(i)).and.(idx(i) <= idxmap%local_cols)&
!!$ & .and.(.not.owned_)) then
!!$ idx(i) = idxmap%loc_to_glob(idx(i)-idxmap%local_rows)
!!$ else
!!$ idx(i) = -1
!!$ info = -1
!!$ end if
!!$ end do
!!$
!!$ end if
!!$
!!$ end subroutine block_l2gv1
!!$
!!$ subroutine block_l2gv2(idxin,idxout,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_gen_block_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(in) :: idxin(:)
!!$ integer(psb_ipk_), intent(out) :: idxout(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: is, im, i
!!$ logical :: owned_
!!$
!!$ info = 0
!!$
!!$ is = size(idxin)
!!$ im = min(is,size(idxout))
!!$
!!$ 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
!!$
!!$ end subroutine block_l2gv2
!!$
subroutine block_ll2gs1(idx,idxmap,info,mask,owned)
implicit none
class(psb_gen_block_map), intent(in) :: idxmap
@ -365,7 +191,6 @@ contains
end subroutine block_ll2gs2
subroutine block_ll2gv1(idx,idxmap,info,mask,owned)
implicit none
class(psb_gen_block_map), intent(in) :: idxmap
@ -489,269 +314,6 @@ contains
end subroutine block_ll2gv2
!!$ subroutine block_g2ls1(idx,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_gen_block_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: idxv(1)
!!$ info = 0
!!$
!!$ if (present(mask)) then
!!$ if (.not.mask) return
!!$ end if
!!$
!!$ idxv(1) = idx
!!$ call idxmap%g2lip(idxv,info,owned=owned)
!!$ idx = idxv(1)
!!$
!!$ end subroutine block_g2ls1
!!$
!!$ subroutine block_g2ls2(idxin,idxout,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_gen_block_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(in) :: idxin
!!$ integer(psb_ipk_), intent(out) :: idxout
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ logical, intent(in), optional :: owned
!!$
!!$ idxout = idxin
!!$ call idxmap%g2lip(idxout,info,mask,owned)
!!$
!!$ end subroutine block_g2ls2
!!$
!!$
!!$ subroutine block_g2lv1(idx,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(inout) :: idx(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: i, nv, is, ip, lip
!!$ integer(psb_lpk_) :: tidx
!!$ integer(psb_mpk_) :: ctxt, iam, np
!!$ logical :: owned_
!!$
!!$ info = 0
!!$ ctxt = idxmap%get_ctxt()
!!$ call psb_info(ctxt,iam,np)
!!$
!!$ if (present(mask)) then
!!$ if (size(mask) < size(idx)) 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
!!$
!!$ is = size(idx)
!!$ if (present(mask)) then
!!$
!!$ if (idxmap%is_asb()) then
!!$ do i=1, is
!!$ if (mask(i)) then
!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then
!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1
!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)&
!!$ &.and.(.not.owned_)) then
!!$ nv = size(idxmap%srt_g2l,1)
!!$ tidx = idx(i)
!!$ idx(i) = psb_bsrch(tidx,nv,idxmap%srt_g2l(:,1))
!!$ if (idx(i) > 0) idx(i) = idxmap%srt_g2l(idx(i),2)+idxmap%local_rows
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end if
!!$ end do
!!$ else if (idxmap%is_valid()) then
!!$ do i=1,is
!!$ if (mask(i)) then
!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then
!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1
!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)&
!!$ &.and.(.not.owned_)) then
!!$ ip = idx(i)
!!$ call psb_hash_searchkey(ip,lip,idxmap%hash,info)
!!$ if (lip > 0) idx(i) = lip + idxmap%local_rows
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end if
!!$ end do
!!$ else
!!$! !$ write(0,*) 'Block status: invalid ',idxmap%get_state()
!!$ idx(1:is) = -1
!!$ info = -1
!!$ end if
!!$
!!$ else if (.not.present(mask)) then
!!$
!!$ if (idxmap%is_asb()) then
!!$ do i=1, is
!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then
!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1
!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)&
!!$ &.and.(.not.owned_)) then
!!$ nv = size(idxmap%srt_g2l,1)
!!$ tidx = idx(i)
!!$ idx(i) = psb_bsrch(tidx,nv,idxmap%srt_g2l(:,1))
!!$ if (idx(i) > 0) idx(i) = idxmap%srt_g2l(idx(i),2)+idxmap%local_rows
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end do
!!$
!!$ else if (idxmap%is_valid()) then
!!$ do i=1,is
!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then
!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1
!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)&
!!$ &.and.(.not.owned_)) then
!!$ ip = idx(i)
!!$ call psb_hash_searchkey(ip,lip,idxmap%hash,info)
!!$ if (lip > 0) idx(i) = lip + idxmap%local_rows
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end do
!!$ else
!!$! !$ write(0,*) 'Block status: invalid ',idxmap%get_state()
!!$ idx(1:is) = -1
!!$ info = -1
!!$ end if
!!$
!!$ end if
!!$
!!$ 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(:)
!!$ integer(psb_ipk_), intent(out) :: idxout(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ logical, intent(in), optional :: owned
!!$
!!$ integer(psb_ipk_) :: i, nv, is, ip, lip, im
!!$ integer(psb_lpk_) :: tidx
!!$ integer(psb_mpk_) :: ctxt, iam, np
!!$ logical :: owned_
!!$
!!$ info = 0
!!$ ctxt = idxmap%get_ctxt()
!!$ call psb_info(ctxt,iam,np)
!!$ is = size(idxin)
!!$ im = min(is,size(idxout))
!!$
!!$ 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_g2l,1)
!!$ tidx = idxin(i)
!!$ idxout(i) = psb_bsrch(tidx,nv,idxmap%srt_g2l(:,1))
!!$ if (idxout(i) > 0) idxout(i) = idxmap%srt_g2l(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_g2l,1)
!!$ tidx = idxin(i)
!!$ idxout(i) = psb_bsrch(tidx,nv,idxmap%srt_g2l(:,1))
!!$ if (idxout(i) > 0) idxout(i) = idxmap%srt_g2l(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
subroutine block_lg2ls1(idx,idxmap,info,mask,owned)
implicit none
class(psb_gen_block_map), intent(in) :: idxmap
@ -794,7 +356,6 @@ contains
end subroutine block_lg2ls2
subroutine block_lg2lv1(idx,idxmap,info,mask,owned)
use psb_penv_mod
use psb_sort_mod
@ -1033,449 +594,6 @@ contains
end subroutine block_lg2lv2
!!$ subroutine block_g2ls1_ins(idx,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(inout) :: idx
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ integer(psb_ipk_), intent(in), optional :: lidx
!!$
!!$ integer(psb_ipk_) :: idxv(1), lidxv(1)
!!$
!!$ info = 0
!!$ if (present(mask)) then
!!$ if (.not.mask) return
!!$ end if
!!$ idxv(1) = idx
!!$ if (present(lidx)) then
!!$ lidxv(1) = lidx
!!$ call idxmap%g2lip_ins(idxv,info,lidx=lidxv)
!!$ else
!!$ call idxmap%g2lip_ins(idxv,info)
!!$ end if
!!$ idx = idxv(1)
!!$
!!$ end subroutine block_g2ls1_ins
!!$
!!$ subroutine block_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx)
!!$ implicit none
!!$ class(psb_gen_block_map), intent(inout) :: idxmap
!!$ integer(psb_ipk_), intent(in) :: idxin
!!$ integer(psb_ipk_), intent(out) :: idxout
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ integer(psb_ipk_), intent(in), optional :: lidx
!!$
!!$ idxout = idxin
!!$ call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx)
!!$
!!$ end subroutine block_g2ls2_ins
!!$
!!$
!!$ subroutine block_g2lv1_ins(idx,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(inout) :: idx(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ integer(psb_ipk_), intent(in), optional :: lidx(:)
!!$
!!$ integer(psb_ipk_) :: i, nv, is, ix
!!$ integer(psb_ipk_) :: ip, lip, nxt
!!$
!!$
!!$ info = 0
!!$ is = size(idx)
!!$
!!$ if (present(mask)) then
!!$ if (size(mask) < size(idx)) then
!!$ info = -1
!!$ return
!!$ end if
!!$ end if
!!$ if (present(lidx)) then
!!$ if (size(lidx) < size(idx)) then
!!$ info = -1
!!$ return
!!$ end if
!!$ end if
!!$
!!$
!!$ if (idxmap%is_asb()) then
!!$ ! State is wrong for this one !
!!$ idx = -1
!!$ info = -1
!!$
!!$ else if (idxmap%is_valid()) then
!!$
!!$ if (present(lidx)) then
!!$ if (present(mask)) then
!!$
!!$ do i=1, is
!!$ if (mask(i)) then
!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then
!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1
!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
!!$
!!$ if (lidx(i) <= idxmap%local_rows) then
!!$ info = -5
!!$ return
!!$ end if
!!$ nxt = lidx(i)-idxmap%local_rows
!!$ ip = idx(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) = idx(i)
!!$ end if
!!$ info = psb_success_
!!$ else
!!$ info = -5
!!$ return
!!$ end if
!!$ idx(i) = lip + idxmap%local_rows
!!$ else
!!$ idx(i) = -1
!!$ info = -1
!!$ end if
!!$ end if
!!$ end do
!!$
!!$ else if (.not.present(mask)) then
!!$
!!$ do i=1, is
!!$
!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then
!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1
!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
!!$ if (lidx(i) <= idxmap%local_rows) then
!!$ info = -5
!!$ return
!!$ end if
!!$ nxt = lidx(i)-idxmap%local_rows
!!$ ip = idx(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) = idx(i)
!!$ end if
!!$ info = psb_success_
!!$ else
!!$ info = -5
!!$ return
!!$ end if
!!$ idx(i) = lip + idxmap%local_rows
!!$ else
!!$ idx(i) = -1
!!$ info = -1
!!$ end if
!!$ end do
!!$ end if
!!$
!!$ else if (.not.present(lidx)) then
!!$
!!$ if (present(mask)) then
!!$ do i=1, is
!!$ if (mask(i)) then
!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then
!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1
!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
!!$ nv = idxmap%local_cols-idxmap%local_rows
!!$ nxt = nv + 1
!!$ ip = idx(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) = idx(i)
!!$ end if
!!$ info = psb_success_
!!$ else
!!$ info = -5
!!$ return
!!$ end if
!!$ idx(i) = lip + idxmap%local_rows
!!$ else
!!$ idx(i) = -1
!!$ info = -1
!!$ end if
!!$ end if
!!$ end do
!!$
!!$ else if (.not.present(mask)) then
!!$
!!$ do i=1, is
!!$
!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then
!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1
!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
!!$ nv = idxmap%local_cols-idxmap%local_rows
!!$ nxt = nv + 1
!!$ ip = idx(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) = idx(i)
!!$ end if
!!$ info = psb_success_
!!$ else
!!$ info = -5
!!$ return
!!$ end if
!!$ idx(i) = lip + idxmap%local_rows
!!$ else
!!$ idx(i) = -1
!!$ info = -1
!!$ end if
!!$ end do
!!$ end if
!!$ end if
!!$
!!$ else
!!$ idx = -1
!!$ info = -1
!!$ end if
!!$
!!$ 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(:)
!!$ integer(psb_ipk_), intent(out) :: idxout(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ integer(psb_ipk_), intent(in), optional :: lidx(:)
!!$
!!$ integer(psb_ipk_) :: i, nv, is, ix, im
!!$ integer(psb_ipk_) :: ip, lip, nxt
!!$
!!$
!!$ info = 0
!!$
!!$ is = size(idxin)
!!$ im = min(is,size(idxout))
!!$
!!$ 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
!!$ end if
!!$
!!$ end subroutine block_g2lv2_ins
subroutine block_lg2ls1_ins(idx,idxmap,info,mask, lidx)
use psb_realloc_mod
use psb_sort_mod
@ -1518,7 +636,6 @@ contains
idxout = tidx
end subroutine block_lg2ls2_ins
subroutine block_lg2lv1_ins(idx,idxmap,info,mask,lidx)
use psb_realloc_mod
use psb_sort_mod

151
base/modules/desc/psb_hash_map_mod.f90
Unescape Escape View File

@ -94,8 +94,6 @@ module psb_hash_map_mod
procedure, pass(idxmap) :: lg2lv1_ins => hash_g2lv1_ins
procedure, pass(idxmap) :: lg2lv2_ins => hash_g2lv2_ins
!!$ procedure, pass(idxmap) :: hash_cpy
!!$ generic, public :: assignment(=) => hash_cpy
procedure, pass(idxmap) :: bld_g2l_map => hash_bld_g2l_map
end type psb_hash_map
@ -443,6 +441,8 @@ contains
end subroutine hash_g2lv1
subroutine hash_g2lv2(idxin,idxout,idxmap,info,mask,owned)
use psb_penv_mod
use psb_sort_mod
use psb_realloc_mod
implicit none
class(psb_hash_map), intent(in) :: idxmap
@ -452,17 +452,120 @@ contains
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_ipk_) :: is, im
integer(psb_lpk_), allocatable :: tidx(:)
integer(psb_ipk_) :: i, lip, nrow, nrm, is, im
integer(psb_lpk_) :: ncol, ip, tlip, mglob
type(psb_ctxt_type) :: ctxt
integer(psb_mpk_) :: iam, np
logical :: owned_
is = size(idxin)
im = min(is,size(idxout))
call psb_realloc(im,tidx,info)
tidx(1:im) = idxin(1:im)
call idxmap%g2lip(tidx(1:im),info,mask,owned)
idxout(1:im) = tidx(1:im)
if (is > im) then
write(0,*) 'g2lv2 err -3'
info = -3
info = 0
ctxt = idxmap%get_ctxt()
call psb_info(ctxt,iam,np)
if (present(mask)) then
if (size(mask) < size(idxin)) then
info = -1
return
end if
end if
if (present(owned)) then
owned_ = owned
else
owned_ = .false.
end if
is = min(size(idxin), size(idxout))
mglob = idxmap%get_gr()
nrow = idxmap%get_lr()
ncol = idxmap%get_lc()
if (owned_) then
nrm = nrow
else
nrm = ncol
end if
if (present(mask)) then
if (idxmap%is_asb()) then
call hash_inner_cnv(is,idxin,idxout,idxmap%hashvmask,&
& idxmap%hashv,idxmap%glb_lc,mask=mask, nrm=nrm)
else if (idxmap%is_valid()) then
do i = 1, is
if (mask(i)) then
ip = idxin(i)
if ((ip < 1 ).or.(ip>mglob)) then
idxout(i) = -1
cycle
endif
call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,&
& idxmap%glb_lc,nrm)
if (lip < 0) then
call psb_hash_searchkey(ip,tlip,idxmap%hash,info)
lip = tlip
end if
if (owned_) then
if (lip<=nrow) then
idxout(i) = lip
else
idxout(i) = -1
endif
else
idxout(i) = lip
endif
end if
enddo
else
write(0,*) 'Hash status: invalid ',idxmap%get_state()
idxout(1:is) = -1
info = -1
end if
else if (.not.present(mask)) then
if (idxmap%is_asb()) then
call hash_inner_cnv(is,idxin,idxout,idxmap%hashvmask,&
& idxmap%hashv,idxmap%glb_lc,nrm=nrm)
else if (idxmap%is_valid()) then
do i = 1, is
ip = idxin(i)
if ((ip < 1 ).or.(ip>mglob)) then
idxout(i) = -1
cycle
endif
call hash_inner_cnv(ip,lip,idxmap%hashvmask,&
& idxmap%hashv,idxmap%glb_lc,nrm)
if (lip < 0) then
call psb_hash_searchkey(ip,tlip,idxmap%hash,info)
lip = tlip
end if
if (owned_) then
if (lip<=nrow) then
idxout(i) = lip
else
idxout(i) = -1
endif
else
idxout(i) = lip
endif
enddo
else
write(0,*) 'Hash status: invalid ',idxmap%get_state()
idxout(1:is) = -1
info = -1
end if
end if
end subroutine hash_g2lv2
@ -1502,32 +1605,6 @@ contains
return
end subroutine hash_clone
!!$ subroutine hash_cpy(outmap,idxmap)
!!$ use psb_penv_mod
!!$ use psb_error_mod
!!$ use psb_realloc_mod
!!$ implicit none
!!$ class(psb_hash_map), intent(in) :: idxmap
!!$ type(psb_hash_map), intent(out) :: outmap
!!$ integer(psb_ipk_) :: info
!!$
!!$ info = psb_success_
!!$ call idxmap%psb_indx_map%cpy(outmap%psb_indx_map,info)
!!$ if (info == psb_success_) then
!!$ outmap%hashvsize = idxmap%hashvsize
!!$ outmap%hashvmask = idxmap%hashvmask
!!$ end if
!!$ if (info == psb_success_)&
!!$ & call psb_safe_ab_cpy(idxmap%loc_to_glob,outmap%loc_to_glob,info)
!!$ if (info == psb_success_)&
!!$ & call psb_safe_ab_cpy(idxmap%hashv,outmap%hashv,info)
!!$ if (info == psb_success_)&
!!$ & call psb_safe_ab_cpy(idxmap%glb_lc,outmap%glb_lc,info)
!!$ if (info == psb_success_)&
!!$ & call psb_hash_copy(idxmap%hash,outmap%hash,info)
!!$ end subroutine hash_cpy
subroutine hash_reinit(idxmap,info)
use psb_penv_mod
use psb_error_mod

660
base/modules/desc/psb_list_map_mod.f90
Unescape Escape View File

@ -59,31 +59,16 @@ module psb_list_map_mod
procedure, nopass :: get_fmt => list_get_fmt
procedure, nopass :: row_extendable => list_row_extendable
!!$ procedure, pass(idxmap) :: l2gs1 => list_l2gs1
!!$ procedure, pass(idxmap) :: l2gs2 => list_l2gs2
!!$ procedure, pass(idxmap) :: l2gv1 => list_l2gv1
!!$ procedure, pass(idxmap) :: l2gv2 => list_l2gv2
procedure, pass(idxmap) :: ll2gs1 => list_ll2gs1
procedure, pass(idxmap) :: ll2gs2 => list_ll2gs2
procedure, pass(idxmap) :: ll2gv1 => list_ll2gv1
procedure, pass(idxmap) :: ll2gv2 => list_ll2gv2
!!$ procedure, pass(idxmap) :: g2ls1 => list_g2ls1
!!$ procedure, pass(idxmap) :: g2ls2 => list_g2ls2
!!$ procedure, pass(idxmap) :: g2lv1 => list_g2lv1
!!$ procedure, pass(idxmap) :: g2lv2 => list_g2lv2
procedure, pass(idxmap) :: lg2ls1 => list_lg2ls1
procedure, pass(idxmap) :: lg2ls2 => list_lg2ls2
procedure, pass(idxmap) :: lg2lv1 => list_lg2lv1
procedure, pass(idxmap) :: lg2lv2 => list_lg2lv2
!!$ procedure, pass(idxmap) :: g2ls1_ins => list_g2ls1_ins
!!$ procedure, pass(idxmap) :: g2ls2_ins => list_g2ls2_ins
!!$ procedure, pass(idxmap) :: g2lv1_ins => list_g2lv1_ins
!!$ procedure, pass(idxmap) :: g2lv2_ins => list_g2lv2_ins
procedure, pass(idxmap) :: lg2ls1_ins => list_lg2ls1_ins
procedure, pass(idxmap) :: lg2ls2_ins => list_lg2ls2_ins
procedure, pass(idxmap) :: lg2lv1_ins => list_lg2lv1_ins
@ -135,115 +120,6 @@ contains
end subroutine list_free
!!$ subroutine list_l2gs1(idx,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: idxv(1)
!!$ info = 0
!!$ if (present(mask)) then
!!$ if (.not.mask) return
!!$ end if
!!$
!!$ idxv(1) = idx
!!$ call idxmap%l2gip(idxv,info,owned=owned)
!!$ idx = idxv(1)
!!$
!!$ end subroutine list_l2gs1
!!$
!!$ subroutine list_l2gs2(idxin,idxout,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(in) :: idxin
!!$ integer(psb_ipk_), intent(out) :: idxout
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ logical, intent(in), optional :: owned
!!$
!!$ idxout = idxin
!!$ call idxmap%l2gip(idxout,info,mask,owned)
!!$
!!$ end subroutine list_l2gs2
!!$
!!$
!!$ subroutine list_l2gv1(idx,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: i
!!$ logical :: owned_
!!$ info = 0
!!$
!!$ if (present(mask)) then
!!$ if (size(mask) < size(idx)) 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, size(idx)
!!$ if (mask(i)) then
!!$ if ((1<=idx(i)).and.(idx(i) <= idxmap%get_lr())) then
!!$ idx(i) = idxmap%loc_to_glob(idx(i))
!!$ else if ((idxmap%get_lr() < idx(i)).and.(idx(i) <= idxmap%local_cols)&
!!$ & .and.(.not.owned_)) then
!!$ idx(i) = idxmap%loc_to_glob(idx(i))
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end if
!!$ end do
!!$
!!$ else if (.not.present(mask)) then
!!$
!!$ do i=1, size(idx)
!!$ if ((1<=idx(i)).and.(idx(i) <= idxmap%get_lr())) then
!!$ idx(i) = idxmap%loc_to_glob(idx(i))
!!$ else if ((idxmap%get_lr() < idx(i)).and.(idx(i) <= idxmap%local_cols)&
!!$ & .and.(.not.owned_)) then
!!$ idx(i) = idxmap%loc_to_glob(idx(i))
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end do
!!$
!!$ end if
!!$
!!$ end subroutine list_l2gv1
!!$
!!$ subroutine list_l2gv2(idxin,idxout,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(in) :: idxin(:)
!!$ integer(psb_ipk_), intent(out) :: idxout(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: is, im
!!$
!!$ is = size(idxin)
!!$ im = min(is,size(idxout))
!!$ idxout(1:im) = idxin(1:im)
!!$ call idxmap%l2gip(idxout(1:im),info,mask,owned)
!!$ if (is > im) info = -3
!!$
!!$ end subroutine list_l2gv2
!!$
subroutine list_ll2gs1(idx,idxmap,info,mask,owned)
implicit none
class(psb_list_map), intent(in) :: idxmap
@ -351,129 +227,6 @@ contains
end subroutine list_ll2gv2
!!$
!!$ subroutine list_g2ls1(idx,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: idxv(1)
!!$ info = 0
!!$
!!$ if (present(mask)) then
!!$ if (.not.mask) return
!!$ end if
!!$
!!$ idxv(1) = idx
!!$ call idxmap%g2lip(idxv,info,owned=owned)
!!$ idx = idxv(1)
!!$
!!$ end subroutine list_g2ls1
!!$
!!$ subroutine list_g2ls2(idxin,idxout,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(in) :: idxin
!!$ integer(psb_ipk_), intent(out) :: idxout
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ logical, intent(in), optional :: owned
!!$
!!$ idxout = idxin
!!$ call idxmap%g2lip(idxout,info,mask,owned)
!!$
!!$ end subroutine list_g2ls2
!!$
!!$
!!$ subroutine list_g2lv1(idx,idxmap,info,mask,owned)
!!$ use psb_sort_mod
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ logical, intent(in), optional :: owned
!!$ integer(psb_ipk_) :: i, is, ix
!!$ logical :: owned_
!!$
!!$ info = 0
!!$
!!$ if (present(mask)) then
!!$ if (size(mask) < size(idx)) then
!!$ info = -1
!!$ return
!!$ end if
!!$ end if
!!$ if (present(owned)) then
!!$ owned_ = owned
!!$ else
!!$ owned_ = .false.
!!$ end if
!!$
!!$ is = size(idx)
!!$
!!$ if (present(mask)) then
!!$ if (idxmap%is_valid()) then
!!$ do i=1,is
!!$ if (mask(i)) then
!!$ if ((1 <= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
!!$ ix = idxmap%glob_to_loc(idx(i))
!!$ if ((ix > idxmap%get_lr()).and.(owned_)) ix = -1
!!$ idx(i) = ix
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end if
!!$ end do
!!$ else
!!$ idx(1:is) = -1
!!$ info = -1
!!$ end if
!!$
!!$ else if (.not.present(mask)) then
!!$
!!$ if (idxmap%is_valid()) then
!!$ do i=1, is
!!$ if ((1 <= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
!!$ ix = idxmap%glob_to_loc(idx(i))
!!$ if ((ix > idxmap%get_lr()).and.(owned_)) ix = -1
!!$ idx(i) = ix
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end do
!!$ else
!!$ idx(1:is) = -1
!!$ info = -1
!!$ end if
!!$
!!$ end if
!!$
!!$ end subroutine list_g2lv1
!!$
!!$ subroutine list_g2lv2(idxin,idxout,idxmap,info,mask,owned)
!!$ implicit none
!!$ class(psb_list_map), intent(in) :: idxmap
!!$ integer(psb_ipk_), intent(in) :: idxin(:)
!!$ integer(psb_ipk_), intent(out) :: idxout(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ logical, intent(in), optional :: owned
!!$
!!$ integer(psb_ipk_) :: is, im
!!$
!!$ is = size(idxin)
!!$ im = min(is,size(idxout))
!!$ idxout(1:im) = idxin(1:im)
!!$ call idxmap%g2lip(idxout(1:im),info,mask,owned)
!!$ if (is > im) info = -3
!!$
!!$ end subroutine list_g2lv2
subroutine list_lg2ls1(idx,idxmap,info,mask,owned)
implicit none
class(psb_list_map), intent(in) :: idxmap
@ -590,227 +343,66 @@ contains
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
logical, intent(in), optional :: owned
integer(psb_lpk_), allocatable :: idxv(:)
integer(psb_ipk_) :: is, im
is = size(idxin)
im = min(is,size(idxout))
allocate(idxv(im),stat=info)
if (info /= 0) then
info = -5
return
integer(psb_ipk_) :: im
integer(psb_lpk_) :: i, is, ix
logical :: owned_
info = 0
if (present(mask)) then
if (size(mask) < size(idxin)) then
info = -1
return
end if
end if
if (present(owned)) then
owned_ = owned
else
owned_ = .false.
end if
idxv(1:im) = idxin(1:im)
call idxmap%g2lip(idxv(1:im),info,mask,owned)
idxout(1:im) = idxv(1:im)
if (is > im) info = -3
end subroutine list_lg2lv2
is = min(size(idxin), size(idxout))
if (present(mask)) then
if (idxmap%is_valid()) then
do i=1,is
if (mask(i)) then
if ((1 <= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then
ix = idxmap%glob_to_loc(idxin(i))
if ((ix > idxmap%get_lr()).and.(owned_)) ix = -1
idxout(i) = ix
else
idxout(i) = -1
end if
end if
end do
else
idxout(1:is) = -1
info = -1
end if
!!$ subroutine list_g2ls1_ins(idx,idxmap,info,mask,lidx)
!!$ use psb_realloc_mod
!!$ use psb_sort_mod
!!$ implicit none
!!$ class(psb_list_map), intent(inout) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ integer(psb_ipk_), intent(in), optional :: lidx
!!$
!!$ integer(psb_ipk_) :: idxv(1), lidxv(1)
!!$
!!$ info = 0
!!$ if (present(mask)) then
!!$ if (.not.mask) return
!!$ end if
!!$ idxv(1) = idx
!!$ if (present(lidx)) then
!!$ lidxv(1) = lidx
!!$ call idxmap%g2lip_ins(idxv,info,lidx=lidxv)
!!$ else
!!$ call idxmap%g2lip_ins(idxv,info)
!!$ end if
!!$
!!$ idx = idxv(1)
!!$
!!$ end subroutine list_g2ls1_ins
!!$
!!$ subroutine list_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx)
!!$ implicit none
!!$ class(psb_list_map), intent(inout) :: idxmap
!!$ integer(psb_ipk_), intent(in) :: idxin
!!$ integer(psb_ipk_), intent(out) :: idxout
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask
!!$ integer(psb_ipk_), intent(in), optional :: lidx
!!$
!!$ idxout = idxin
!!$ call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx)
!!$
!!$ end subroutine list_g2ls2_ins
!!$
!!$
!!$ subroutine list_g2lv1_ins(idx,idxmap,info,mask,lidx)
!!$ use psb_realloc_mod
!!$ use psb_sort_mod
!!$ implicit none
!!$ class(psb_list_map), intent(inout) :: idxmap
!!$ integer(psb_ipk_), intent(inout) :: idx(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ integer(psb_ipk_), intent(in), optional :: lidx(:)
!!$
!!$ integer(psb_ipk_) :: i, is, ix, lix
!!$
!!$ info = 0
!!$ is = size(idx)
!!$
!!$ if (present(mask)) then
!!$ if (size(mask) < size(idx)) then
!!$ info = -1
!!$ return
!!$ end if
!!$ end if
!!$ if (present(lidx)) then
!!$ if (size(lidx) < size(idx)) then
!!$ info = -1
!!$ return
!!$ end if
!!$ end if
!!$
!!$
!!$ if (idxmap%is_asb()) then
!!$ ! State is wrong for this one !
!!$ idx = -1
!!$ info = -1
!!$
!!$ else if (idxmap%is_valid()) then
!!$
!!$ if (present(lidx)) then
!!$ if (present(mask)) then
!!$ do i=1, is
!!$ if (mask(i)) then
!!$ if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
!!$ ix = idxmap%glob_to_loc(idx(i))
!!$ if (ix < 0) then
!!$ ix = lidx(i)
!!$ call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz)
!!$ if ((ix <= idxmap%local_rows).or.(info /= 0)) then
!!$ info = -4
!!$ return
!!$ end if
!!$ idxmap%local_cols = max(ix,idxmap%local_cols)
!!$ idxmap%loc_to_glob(ix) = idx(i)
!!$ idxmap%glob_to_loc(idx(i)) = ix
!!$ end if
!!$ idx(i) = ix
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end if
!!$ end do
!!$
!!$ else if (.not.present(mask)) then
!!$
!!$ do i=1, is
!!$ if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
!!$ ix = idxmap%glob_to_loc(idx(i))
!!$ if (ix < 0) then
!!$ ix = lidx(i)
!!$ call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz)
!!$ if ((ix <= idxmap%local_rows).or.(info /= 0)) then
!!$ info = -4
!!$ return
!!$ end if
!!$ idxmap%local_cols = max(ix,idxmap%local_cols)
!!$ idxmap%loc_to_glob(ix) = idx(i)
!!$ idxmap%glob_to_loc(idx(i)) = ix
!!$ end if
!!$ idx(i) = ix
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end do
!!$ end if
!!$
!!$ else if (.not.present(lidx)) then
!!$
!!$ if (present(mask)) then
!!$ do i=1, is
!!$ if (mask(i)) then
!!$ if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
!!$ ix = idxmap%glob_to_loc(idx(i))
!!$ if (ix < 0) then
!!$ ix = idxmap%local_cols + 1
!!$ call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz)
!!$ if (info /= 0) then
!!$ info = -4
!!$ return
!!$ end if
!!$ idxmap%local_cols = ix
!!$ idxmap%loc_to_glob(ix) = idx(i)
!!$ idxmap%glob_to_loc(idx(i)) = ix
!!$ end if
!!$ idx(i) = ix
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end if
!!$ end do
!!$
!!$ else if (.not.present(mask)) then
!!$
!!$ do i=1, is
!!$ if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then
!!$ ix = idxmap%glob_to_loc(idx(i))
!!$ if (ix < 0) then
!!$ ix = idxmap%local_cols + 1
!!$ call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz)
!!$ if (info /= 0) then
!!$ info = -4
!!$ return
!!$ end if
!!$ idxmap%local_cols = ix
!!$ idxmap%loc_to_glob(ix) = idx(i)
!!$ idxmap%glob_to_loc(idx(i)) = ix
!!$ end if
!!$ idx(i) = ix
!!$ else
!!$ idx(i) = -1
!!$ end if
!!$ end do
!!$ end if
!!$ end if
!!$
!!$ else
!!$ idx = -1
!!$ info = -1
!!$ end if
!!$
!!$ end subroutine list_g2lv1_ins
!!$
!!$ subroutine list_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx)
!!$ implicit none
!!$ class(psb_list_map), intent(inout) :: idxmap
!!$ integer(psb_ipk_), intent(in) :: idxin(:)
!!$ integer(psb_ipk_), intent(out) :: idxout(:)
!!$ integer(psb_ipk_), intent(out) :: info
!!$ logical, intent(in), optional :: mask(:)
!!$ integer(psb_ipk_), intent(in), optional :: lidx(:)
!!$
!!$ integer(psb_ipk_) :: is, im
!!$
!!$ 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 (is > im) info = -3
!!$
!!$ end subroutine list_g2lv2_ins
!!$
else if (.not.present(mask)) then
if (idxmap%is_valid()) then
do i=1, is
if ((1 <= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then
ix = idxmap%glob_to_loc(idxin(i))
if ((ix > idxmap%get_lr()).and.(owned_)) ix = -1
idxout(i) = ix
else
idxout(i) = -1
end if
end do
else
idxout(1:is) = -1
info = -1
end if
end if
end subroutine list_lg2lv2
subroutine list_lg2ls1_ins(idx,idxmap,info,mask,lidx)
use psb_realloc_mod
use psb_sort_mod
@ -1010,6 +602,7 @@ contains
end subroutine list_lg2lv1_ins
subroutine list_lg2lv2_ins(idxin,idxout,idxmap,info,mask,lidx)
use psb_realloc_mod
implicit none
class(psb_list_map), intent(inout) :: idxmap
integer(psb_lpk_), intent(in) :: idxin(:)
@ -1017,27 +610,136 @@ contains
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: mask(:)
integer(psb_ipk_), intent(in), optional :: lidx(:)
integer(psb_lpk_) :: is, im
integer(psb_lpk_), allocatable :: idxv(:)
is = size(idxin)
im = min(is,size(idxout))
allocate(idxv(im),stat=info)
if (info /= 0) then
info = -5
return
integer(psb_ipk_) :: ix, lix
integer(psb_lpk_) :: i, is
info = 0
is = min(size(idxin),size(idxout))
if (present(mask)) then
if (size(mask) < size(idxin)) then
info = -1
return
end if
end if
if (present(lidx)) then
if (size(lidx) < size(idxin)) then
info = -1
return
end if
end if
idxv(1:im) = idxin(1:im)
call idxmap%g2lip_ins(idxv(1:im),info,mask=mask,lidx=lidx)
idxout(1:im) = idxv(1:im)
if (is > im) info = -3
end subroutine list_lg2lv2_ins
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, is
if (mask(i)) then
if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then
ix = idxmap%glob_to_loc(idxin(i))
if (ix < 0) then
ix = lidx(i)
call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz)
if ((ix <= idxmap%local_rows).or.(info /= 0)) then
info = -4
return
end if
idxmap%local_cols = max(ix,idxmap%local_cols)
idxmap%loc_to_glob(ix) = idxin(i)
idxmap%glob_to_loc(idxin(i)) = ix
end if
idxout(i) = ix
else
idxout(i) = -1
end if
end if
end do
else if (.not.present(mask)) then
do i=1, is
if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then
ix = idxmap%glob_to_loc(idxin(i))
if (ix < 0) then
ix = lidx(i)
call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz)
if ((ix <= idxmap%local_rows).or.(info /= 0)) then
info = -4
return
end if
idxmap%local_cols = max(ix,idxmap%local_cols)
idxmap%loc_to_glob(ix) = idxin(i)
idxmap%glob_to_loc(idxin(i)) = ix
end if
idxout(i) = ix
else
idxout(i) = -1
end if
end do
end if
else if (.not.present(lidx)) then
if (present(mask)) then
do i=1, is
if (mask(i)) then
if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then
ix = idxmap%glob_to_loc(idxin(i))
if (ix < 0) then
ix = idxmap%local_cols + 1
call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz)
if (info /= 0) then
info = -4
return
end if
idxmap%local_cols = ix
idxmap%loc_to_glob(ix) = idxin(i)
idxmap%glob_to_loc(idxin(i)) = ix
end if
idxout(i) = ix
else
idxout(i) = -1
end if
end if
end do
else if (.not.present(mask)) then
do i=1, is
if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then
ix = idxmap%glob_to_loc(idxin(i))
if (ix < 0) then
ix = idxmap%local_cols + 1
call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz)
if (info /= 0) then
info = -4
return
end if
idxmap%local_cols = ix
idxmap%loc_to_glob(ix) = idxin(i)
idxmap%glob_to_loc(idxin(i)) = ix
end if
idxout(i) = ix
else
idxout(i) = -1
end if
end do
end if
end if
else
idxout = -1
info = -1
end if
end subroutine list_lg2lv2_ins
subroutine list_initvl(idxmap,ctxt,vl,info)
use psb_penv_mod

Write Preview
Loading…
Cancel
Save