From 9bab3163d571db9e8028160584291bfe2e44231e Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 28 Feb 2018 10:19:26 +0000 Subject: [PATCH] Changes to gen_block. Does not build fully yet. --- base/modules/desc/psb_gen_block_map_mod.f90 | 1168 +++++++++++++++++-- 1 file changed, 1052 insertions(+), 116 deletions(-) diff --git a/base/modules/desc/psb_gen_block_map_mod.f90 b/base/modules/desc/psb_gen_block_map_mod.f90 index 3afae81b..9acc1c7f 100644 --- a/base/modules/desc/psb_gen_block_map_mod.f90 +++ b/base/modules/desc/psb_gen_block_map_mod.f90 @@ -54,7 +54,7 @@ module psb_gen_block_map_mod type, extends(psb_indx_map) :: psb_gen_block_map integer(psb_lpk_) :: min_glob_row = -1 integer(psb_lpk_) :: max_glob_row = -1 - integer(psb_ipk_), allocatable :: loc_to_glob(:), srt_l2g(:,:), vnl(:) + integer(psb_lpk_), allocatable :: loc_to_glob(:), srt_l2g(:,:), vnl(:) type(psb_hash_type) :: hash contains @@ -72,26 +72,47 @@ module psb_gen_block_map_mod 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 + procedure, pass(idxmap) :: lg2lv2_ins => block_lg2lv2_ins + procedure, pass(idxmap) :: fnd_owner => block_fnd_owner end type psb_gen_block_map private :: block_init, block_sizeof, block_asb, block_free,& - & block_get_fmt, block_l2gs1, block_l2gs2, block_l2gv1,& - & block_l2gv2, block_g2ls1, block_g2ls2, block_g2lv1,& - & block_g2lv2, block_g2ls1_ins, block_g2ls2_ins,& - & block_g2lv1_ins, block_g2lv2_ins, block_clone, block_reinit,& - & gen_block_search + & block_l2gs1, block_l2gs2, block_l2gv1, block_l2gv2, & + & block_ll2gs1, block_ll2gs2, block_ll2gv1, block_ll2gv2, & + & block_g2ls1, block_g2ls2, block_g2lv1, block_g2lv2, & + & block_g2ls1_ins, block_g2ls2_ins, block_g2lv1_ins, block_g2lv2_ins, & + & block_lg2ls1_ins, block_lg2ls2_ins, block_lg2lv1_ins, block_lg2lv2_ins, & + & block_clone, block_reinit,& + & block_get_fmt, gen_block_search, l_gen_block_search + + interface gen_block_search + module procedure gen_block_search, l_gen_block_search + end interface gen_block_search integer(psb_ipk_), private :: laddsz=500 @@ -104,13 +125,13 @@ contains integer(psb_long_int_k_) :: val val = idxmap%psb_indx_map%sizeof() - val = val + 2 * psb_sizeof_int + val = val + 2 * psb_sizeof_long_int if (allocated(idxmap%loc_to_glob)) & - & val = val + size(idxmap%loc_to_glob)*psb_sizeof_int + & val = val + size(idxmap%loc_to_glob)*psb_sizeof_long_int if (allocated(idxmap%srt_l2g)) & - & val = val + size(idxmap%srt_l2g)*psb_sizeof_int + & val = val + size(idxmap%srt_l2g)*psb_sizeof_long_int if (allocated(idxmap%vnl)) & - & val = val + size(idxmap%vnl)*psb_sizeof_int + & val = val + size(idxmap%vnl)*psb_sizeof_long_int val = val + psb_sizeof(idxmap%hash) end function block_sizeof @@ -290,6 +311,164 @@ contains end subroutine block_l2gv2 + subroutine block_ll2gs1(idx,idxmap,info,mask,owned) + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + integer(psb_lpk_), intent(inout) :: idx + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer(psb_lpk_) :: 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_ll2gs1 + + subroutine block_ll2gs2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + integer(psb_ipk_), intent(in) :: idxin + integer(psb_lpk_), 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_ll2gs2 + + + subroutine block_ll2gv1(idx,idxmap,info,mask,owned) + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + integer(psb_lpk_), 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_ll2gv1 + + subroutine block_ll2gv2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + integer(psb_ipk_), intent(in) :: idxin(:) + integer(psb_lpk_), 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_ll2gv2 + + subroutine block_g2ls1(idx,idxmap,info,mask,owned) implicit none class(psb_gen_block_map), intent(in) :: idxmap @@ -335,6 +514,7 @@ contains logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned integer(psb_ipk_) :: i, nv, is, ip, lip + integer(psb_lpk_) :: tidx integer(psb_mpik_) :: ictxt, iam, np logical :: owned_ @@ -366,7 +546,8 @@ contains else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& &.and.(.not.owned_)) then nv = size(idxmap%srt_l2g,1) - idx(i) = psb_ibsrch(idx(i),nv,idxmap%srt_l2g(:,1)) + tidx = idx(i) + idx(i) = psb_bsrch(tidx,nv,idxmap%srt_l2g(:,1)) if (idx(i) > 0) idx(i) = idxmap%srt_l2g(idx(i),2)+idxmap%local_rows else idx(i) = -1 @@ -403,7 +584,8 @@ contains else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& &.and.(.not.owned_)) then nv = size(idxmap%srt_l2g,1) - idx(i) = psb_ibsrch(idx(i),nv,idxmap%srt_l2g(:,1)) + tidx = idx(i) + idx(i) = psb_bsrch(tidx,nv,idxmap%srt_l2g(:,1)) if (idx(i) > 0) idx(i) = idxmap%srt_l2g(idx(i),2)+idxmap%local_rows else idx(i) = -1 @@ -445,6 +627,7 @@ contains logical, intent(in), optional :: owned integer(psb_ipk_) :: i, nv, is, ip, lip, im + integer(psb_lpk_) :: tidx integer(psb_mpik_) :: ictxt, iam, np logical :: owned_ @@ -454,111 +637,818 @@ contains 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 (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) + tidx = idxin(i) + idxout(i) = psb_bsrch(tidx,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) + tidx = idxin(i) + idxout(i) = psb_bsrch(tidx,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 + + + subroutine block_lg2ls1(idx,idxmap,info,mask,owned) + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + integer(psb_lpk_), intent(inout) :: idx + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer(psb_lpk_) :: 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_lg2ls1 + + subroutine block_lg2ls2(idxin,idxout,idxmap,info,mask,owned) + implicit none + class(psb_gen_block_map), intent(in) :: idxmap + integer(psb_lpk_), 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_lg2ls2 + + + subroutine block_lg2lv1(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_lpk_), 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_mpik_) :: ictxt, iam, np + logical :: owned_ + + info = 0 + ictxt = idxmap%get_ctxt() + call psb_info(ictxt,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_l2g,1) + tidx = idx(i) + idx(i) = psb_bsrch(tidx,nv,idxmap%srt_l2g(:,1)) + if (idx(i) > 0) idx(i) = idxmap%srt_l2g(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_l2g,1) + tidx = idx(i) + idx(i) = psb_bsrch(tidx,nv,idxmap%srt_l2g(:,1)) + if (idx(i) > 0) idx(i) = idxmap%srt_l2g(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_lg2lv1 + + subroutine block_lg2lv2(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_lpk_), 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_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)) + + 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) + tidx = idxin(i) + idxout(i) = psb_bsrch(tidx,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) + tidx = idxin(i) + idxout(i) = psb_bsrch(tidx,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_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 - if (present(mask)) then + do i=1, im - 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 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 (idxmap%is_valid()) then - do i=1,im - if (mask(i)) then + 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)& - &.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 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 -!!$ 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 do + end if end if + else + idxout = -1 + info = -1 end if - if (is > im) info = -3 - - end subroutine block_g2lv2 - + if (is > im) then +!!$ write(0,*) 'g2lv2_ins err -3' + info = -3 + end if + end subroutine block_g2lv2_ins - subroutine block_g2ls1_ins(idx,idxmap,info,mask, lidx) + subroutine block_lg2ls1_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_lpk_), 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) + integer(psb_lpk_) :: idxv(1) + integer(psb_ipk_) :: lidxv(1) info = 0 if (present(mask)) then @@ -573,35 +1463,36 @@ contains end if idx = idxv(1) - end subroutine block_g2ls1_ins + end subroutine block_lg2ls1_ins - subroutine block_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx) + subroutine block_lg2ls2_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_lpk_), 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 + integer(psb_lpk_) :: tidx + tidx = idxin + call idxmap%g2lip_ins(tidx,info,mask=mask,lidx=lidx) + idxout = tidx + end subroutine block_lg2ls2_ins - subroutine block_g2lv1_ins(idx,idxmap,info,mask,lidx) + subroutine block_lg2lv1_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_lpk_), 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 + integer(psb_lpk_) :: ip, lip + integer(psb_ipk_) :: nxt info = 0 @@ -785,21 +1676,22 @@ contains info = -1 end if - end subroutine block_g2lv1_ins + end subroutine block_lg2lv1_ins - subroutine block_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) + subroutine block_lg2lv2_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_lpk_), 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 + integer(psb_lpk_) :: ip, lip, lnxt + integer(psb_ipk_) :: nxt info = 0 @@ -840,11 +1732,12 @@ contains info = -5 return end if - nxt = lidx(i)-idxmap%local_rows + lnxt = lidx(i)-idxmap%local_rows ip = idxin(i) - call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) + call psb_hash_searchinskey(ip,lip,lnxt,idxmap%hash,info) + nxt = lnxt if (info >= 0) then - if (lip == nxt) 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 @@ -878,10 +1771,10 @@ contains info = -5 return end if - nxt = lidx(i)-idxmap%local_rows + lnxt = lidx(i)-idxmap%local_rows ip = idxin(i) - call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) - + call psb_hash_searchinskey(ip,lip,lnxt,idxmap%hash,info) + nxt = lnxt if (info >= 0) then if (lip == nxt) then ! We have added one item @@ -989,7 +1882,7 @@ contains info = -3 end if - end subroutine block_g2lv2_ins + end subroutine block_lg2lv2_ins subroutine block_fnd_owner(idx,iprc,idxmap,info) use psb_penv_mod @@ -999,6 +1892,7 @@ contains class(psb_gen_block_map), intent(in) :: idxmap integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: ictxt, iam, np, nv, ip, i + integer(psb_lpk_) :: tidx ictxt = idxmap%get_ctxt() call psb_info(ictxt,iam,np) @@ -1008,8 +1902,9 @@ contains !!$ write(0,*) 'Memory allocation failure in repl_map_fnd-owner' return end if - do i=1, nv - ip = gen_block_search(idx(i)-1,np+1,idxmap%vnl) + do i=1, nv + tidx = idx(i) + ip = gen_block_search(tidx-1,np+1,idxmap%vnl) iprc(i) = ip - 1 end do @@ -1029,7 +1924,7 @@ contains ! To be implemented integer(psb_mpik_) :: iam, np integer(psb_ipk_) :: i, ntot - integer(psb_ipk_), allocatable :: vnl(:) + integer(psb_lpk_), allocatable :: vnl(:) info = 0 call psb_info(ictxt,iam,np) @@ -1271,5 +2166,46 @@ contains return end function gen_block_search + function l_gen_block_search(key,n,v) result(ipos) + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_lpk_) :: key + integer(psb_lpk_) :: v(:) + + integer(psb_ipk_) :: lb, ub, m + + if (n < 5) then + ! don't bother with binary search for very + ! small vectors + ipos = 0 + do + if (ipos == n) return + if (key < v(ipos+1)) return + ipos = ipos + 1 + end do + else + lb = 1 + ub = n + ipos = -1 + + do while (lb <= ub) + m = (lb+ub)/2 + if (key==v(m)) then + ipos = m + return + else if (key < v(m)) then + ub = m-1 + else + lb = m + 1 + end if + enddo + if (v(ub) > key) then + ub = ub - 1 + end if + ipos = ub + endif + return + end function l_gen_block_search + end module psb_gen_block_map_mod