From 6e450a440c238b63c199ddd1c38aefad6182ad13 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 26 Sep 2013 12:52:04 +0000 Subject: [PATCH] psblas3: base/modules/psb_gen_block_map_mod.f90 Do not (over)use in-place methods --- base/modules/psb_gen_block_map_mod.f90 | 344 ++++++++++++++++++++++++- 1 file changed, 333 insertions(+), 11 deletions(-) diff --git a/base/modules/psb_gen_block_map_mod.f90 b/base/modules/psb_gen_block_map_mod.f90 index 55376b3b..af956199 100644 --- a/base/modules/psb_gen_block_map_mod.f90 +++ b/base/modules/psb_gen_block_map_mod.f90 @@ -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