diff --git a/base/internals/Makefile b/base/internals/Makefile index 5ef4c53e..40143697 100644 --- a/base/internals/Makefile +++ b/base/internals/Makefile @@ -4,7 +4,7 @@ FOBJS = psi_compute_size.o psi_crea_bnd_elem.o psi_crea_index.o \ psi_crea_ovr_elem.o psi_dl_check.o \ psi_gthsct_mod.o \ psi_sort_dl.o \ - psi_ldsc_pre_halo.o\ + psi_ldsc_pre_halo.o psi_bld_tmphalo.o psi_bld_hash.o\ psi_sort_dl.o psi_idx_cnv.o psi_idx_ins_cnv.o psi_fnd_owner.o FOBJS2 = psi_exist_ovr_elem.o psi_list_search.o srtlist.o COBJS = avltree.o srcht.o diff --git a/base/internals/psi_fnd_owner.f90 b/base/internals/psi_fnd_owner.f90 index aaef8612..60d56183 100644 --- a/base/internals/psi_fnd_owner.f90 +++ b/base/internals/psi_fnd_owner.f90 @@ -35,13 +35,13 @@ ! Figure out who owns global indices. ! ! Arguments: -! nv - integer Number of indices required on the calling -! process -! idx(:) - integer Required indices on the calling process -! iprc(:) - integer, allocatable Output: process identifiers for the corresponding -! indices +! nv - integer Number of indices required on the calling +! process +! idx(:) - integer Required indices on the calling process +! iprc(:) - integer, allocatable Output: process identifiers for the corresponding +! indices ! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. return code. +! info - integer. return code. ! subroutine psi_fnd_owner(nv,idx,iprc,desc,info) use psb_descriptor_type @@ -54,7 +54,7 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) implicit none integer, intent(in) :: nv - integer, intent(in) :: idx(:) + integer, intent(in) :: idx(:) integer, allocatable, intent(out) :: iprc(:) type(psb_desc_type), intent(in) :: desc integer, intent(out) :: info diff --git a/base/internals/psi_ldsc_pre_halo.f90 b/base/internals/psi_ldsc_pre_halo.f90 index 799a5bb5..f6b83129 100644 --- a/base/internals/psi_ldsc_pre_halo.f90 +++ b/base/internals/psi_ldsc_pre_halo.f90 @@ -92,96 +92,21 @@ subroutine psi_ldsc_pre_halo(desc,ext_hv,info) goto 9999 end if - - nk = n_col - call psb_realloc(nk,2,desc%glb_lc,info) - if (info ==0) call psb_realloc(psb_hash_size+1,desc%hashv,info,lb=0) + call psi_bld_hash(desc,info) if (info /= 0) then - ch_err='psb_realloc' + ch_err='psi_bld_hash' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - - ! Build a hashed table of sorted lists to search for - ! indices. - desc%hashv(0:psb_hash_size) = 0 - do i=1, nk - key = desc%loc_to_glob(i) - ih = iand(key,psb_hash_mask) - desc%hashv(ih) = desc%hashv(ih) + 1 - end do - nh = desc%hashv(0) - idx = 1 - do i=1, psb_hash_size - desc%hashv(i-1) = idx - idx = idx + nh - nh = desc%hashv(i) - end do - do i=1, nk - key = desc%loc_to_glob(i) - ih = iand(key,psb_hash_mask) - idx = desc%hashv(ih) - desc%glb_lc(idx,1) = key - desc%glb_lc(idx,2) = i - desc%hashv(ih) = desc%hashv(ih) + 1 - end do - do i = psb_hash_size, 1, -1 - desc%hashv(i) = desc%hashv(i-1) - end do - desc%hashv(0) = 1 - do i=0, psb_hash_size-1 - idx = desc%hashv(i) - nh = desc%hashv(i+1) - desc%hashv(i) - if (nh > 1) then - call psb_msort(desc%glb_lc(idx:idx+nh-1,1),& - & ix=desc%glb_lc(idx:idx+nh-1,2),flag=psb_sort_keep_idx_) - end if - end do - if (.not.ext_hv) then - ! Here we do not know yet who owns what, so we have - ! to call fnd_owner. - nh = (n_col-n_row) - if (nh > 0) then - Allocate(helem(nh),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - - do i=1, nh - helem(i) = desc%loc_to_glob(n_row+i) - end do - - call psi_fnd_owner(nh,helem,hproc,desc,info) - allocate(tmphl((3*((n_col-n_row)+1)+1)),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - j = 1 - do i=1,nh - tmphl(j+0) = hproc(i) - if (tmphl(j+0)<0) then - write(0,*) 'Unrecoverable error: missing proc from asb' - end if - tmphl(j+1) = 1 - tmphl(j+2) = n_row+i - j = j + 3 - end do - tmphl(j) = -1 - lhalo = j - nhalo = (lhalo-1)/3 - else - allocate(tmphl(1),stat=info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='Allocate') - goto 9999 - end if - tmphl=-1 - endif - call psb_transfer(tmphl,desc%halo_index,info) + call psi_bld_tmphalo(desc,info) + if (info /= 0) then + ch_err='psi_bld_tmphalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if end if + call psb_erractionrestore(err_act) return diff --git a/base/modules/psi_mod.f90 b/base/modules/psi_mod.f90 index 4690afa2..e4a1edf8 100644 --- a/base/modules/psi_mod.f90 +++ b/base/modules/psi_mod.f90 @@ -235,6 +235,22 @@ module psi_mod integer, intent(out) :: info end subroutine psi_ldsc_pre_halo end interface + + interface psi_bld_hash + subroutine psi_bld_hash(desc,info) + use psb_descriptor_type + type(psb_desc_type), intent(inout) :: desc + integer, intent(out) :: info + end subroutine psi_bld_hash + end interface + + interface psi_bld_tmphalo + subroutine psi_bld_tmphalo(desc,info) + use psb_descriptor_type + type(psb_desc_type), intent(inout) :: desc + integer, intent(out) :: info + end subroutine psi_bld_tmphalo + end interface interface psi_idx_cnv subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned)