diff --git a/base/internals/psi_a2a_fnd_owner.F90 b/base/internals/psi_a2a_fnd_owner.F90 index e10135aa..003ae1bf 100644 --- a/base/internals/psi_a2a_fnd_owner.F90 +++ b/base/internals/psi_a2a_fnd_owner.F90 @@ -60,10 +60,10 @@ subroutine psi_a2a_fnd_owner(idx,iprc,idxmap,info) #ifdef MPI_H include 'mpif.h' #endif - integer(psb_lpk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) class(psb_indx_map), intent(in) :: idxmap - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_lpk_), allocatable :: answers(:,:), idxsrch(:,:), hproc(:) @@ -80,7 +80,7 @@ subroutine psi_a2a_fnd_owner(idx,iprc,idxmap,info) character(len=20) :: name info = psb_success_ - name = 'psb_indx_map_fnd_owner' + name = 'psi_a2a_fnd_owner' call psb_erractionsave(err_act) ictxt = idxmap%get_ctxt() diff --git a/base/internals/psi_adjcncy_fnd_owner.F90 b/base/internals/psi_adjcncy_fnd_owner.F90 index 61aee106..9c989c21 100644 --- a/base/internals/psi_adjcncy_fnd_owner.F90 +++ b/base/internals/psi_adjcncy_fnd_owner.F90 @@ -45,7 +45,7 @@ ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code. ! -subroutine psi_adjcncy_fnd_owner(idx,iprc,idxmap,info) +subroutine psi_adjcncy_fnd_owner(idx,iprc,ladj,idxmap,info) use psb_serial_mod use psb_const_mod use psb_error_mod @@ -60,10 +60,11 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,idxmap,info) #ifdef MPI_H include 'mpif.h' #endif - integer(psb_lpk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) + integer(psb_ipk_), intent(in) :: ladj(:) class(psb_indx_map), intent(in) :: idxmap - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info integer(psb_lpk_), allocatable :: answers(:,:), idxsrch(:,:), hproc(:) @@ -80,7 +81,7 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,idxmap,info) character(len=20) :: name info = psb_success_ - name = 'psb_indx_map_fnd_owner' + name = 'psi_adjcncy_fnd_owner' call psb_erractionsave(err_act) ictxt = idxmap%get_ctxt() @@ -113,11 +114,10 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,idxmap,info) call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_realloc') goto 9999 end if + !write(0,*) me,name,' Going through ',nv,size(ladj) - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=idxmap%get_fmt()) - goto 9999 - + call psi_a2a_fnd_owner(idx,iprc,idxmap,info) + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return diff --git a/base/internals/psi_fnd_owner.F90 b/base/internals/psi_fnd_owner.F90 index 456dd4d4..f2a22e0e 100644 --- a/base/internals/psi_fnd_owner.F90 +++ b/base/internals/psi_fnd_owner.F90 @@ -62,11 +62,11 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: nv - integer(psb_lpk_), intent(in) :: idx(:) + integer(psb_ipk_), intent(in) :: nv + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - type(psb_desc_type), intent(in) :: desc - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), allocatable :: hsz(:),hidx(:),helem(:),hproc(:),& diff --git a/base/internals/psi_graph_fnd_owner.F90 b/base/internals/psi_graph_fnd_owner.F90 index ce3fb837..fa61d1b0 100644 --- a/base/internals/psi_graph_fnd_owner.F90 +++ b/base/internals/psi_graph_fnd_owner.F90 @@ -60,27 +60,27 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info) #ifdef MPI_H include 'mpif.h' #endif - integer(psb_lpk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - class(psb_indx_map), intent(in) :: idxmap - integer(psb_ipk_), intent(out) :: info + class(psb_indx_map), intent(inout) :: idxmap + integer(psb_ipk_), intent(out) :: info - integer(psb_lpk_), allocatable :: answers(:,:), idxsrch(:,:), hproc(:) - integer(psb_ipk_), allocatable :: helem(:), hhidx(:) + integer(psb_lpk_), allocatable :: answers(:,:), idxsrch(:,:), hproc(:), tidx(:) + integer(psb_ipk_), allocatable :: helem(:), hhidx(:), tprc(:), tsmpl(:), ladj(:) integer(psb_mpk_), allocatable :: hsz(:),hidx(:), & & sdsz(:),sdidx(:), rvsz(:), rvidx(:) integer(psb_mpk_) :: icomm, minfo, iictxt integer(psb_ipk_) :: i,n_row,n_col,err_act,hsize,ip,isz,j, k,& - & last_ih, last_j, nv + & last_ih, last_j, nv, n_answers, n_rest, n_samples, locr_max, nrest_max, nadj, maxspace integer(psb_lpk_) :: mglob, ih integer(psb_ipk_) :: ictxt,np,me, nresp logical, parameter :: gettime=.false. - real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx + real(psb_dpk_) :: t0, t1, t2, t3, t4 character(len=20) :: name info = psb_success_ - name = 'psb_indx_map_fnd_owner' + name = 'psi_graph_fnd_owner' call psb_erractionsave(err_act) ictxt = idxmap%get_ctxt() @@ -88,7 +88,7 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info) mglob = idxmap%get_gr() n_row = idxmap%get_lr() n_col = idxmap%get_lc() - iictxt = ictxt + iictxt = ictxt call psb_info(ictxt, me, np) @@ -103,22 +103,90 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info) goto 9999 end if - if (gettime) then - t0 = psb_wtime() - end if + locr_max = n_row + call psb_max(ictxt,locr_max) + ! + ! Choice of maxspace should be adjusted to account for a default + ! "sensible" size and/or a user-specified value + maxspace = 2*locr_max nv = size(idx) call psb_realloc(nv,iprc,info) + if (info == psb_success_) call psb_realloc(nv,tidx,info) + if (info == psb_success_) call psb_realloc(nv,tprc,info) + if (info == psb_success_) call psb_realloc(nv,tsmpl,info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_realloc') goto 9999 end if - - info = psb_err_missing_override_method_ - call psb_errpush(info,name,a_err=idxmap%get_fmt()) - goto 9999 + iprc(:) = -1 + n_answers = 0 + if (.true.) then + ! + ! Start from the adjacncy list + ! + ! Skip for the time being - + n_rest = nv - n_answers + nrest_max = n_rest + call psb_max(ictxt,nrest_max) + fnd_owner_loop: do while (nrest_max>0) + ! + ! The basic idea of this loop is to alternate between + ! searching through all processes and searching + ! in the neighbourood. + ! + ! 1. Select a sample to be sent to all processes; sample + ! size is such that the total size is <= maxspace + ! + if (me == 0) write(0,*) 'Looping in graph_fnd_owner: ', nrest_max + n_samples = min(n_rest,max(1,(maxspace+np-1)/np)) + ! + ! Choose a sample, should it be done in this simplistic way? + ! + call psi_get_sample(idx,tidx,tsmpl,n_samples,k) + n_samples = min(k,n_samples) + ! + ! 2. Do a search on all processes; this is supposed to find + ! the owning process for all inputs; + ! + call psi_a2a_fnd_owner(tidx(1:n_samples),tprc,idxmap,info) + call psi_cpy_out(iprc,tprc,tsmpl,n_samples,k) + if (k /= n_samples) then + write(0,*) me,'Warning: indices not found by a2a_fnd_owner ',k,n_samples + end if + n_answers = n_answers + k + n_rest = nv - n_answers + ! + ! 3. Extract the resulting adjacency list and add it to the + ! indxmap; + ! + ladj = tprc(1:n_samples) + call psb_msort_unique(ladj,nadj) + ! + ! NOTE: should symmetrize the list... + ! + call idxmap%xtnd_p_adjcncy(ladj(1:nadj)) + + ! + ! 4. Extract a sample and do a neighbourhood search so that the total + ! size is <= maxspace + ! (will not be exact since nadj varies with process) + ! + n_samples = min(n_rest,max(1,(maxspace+max(1,nadj)-1))/(max(1,nadj))) + call psi_get_sample(idx,tidx,tsmpl,n_samples,k) + n_samples = min(k,n_samples) + call psi_adjcncy_fnd_owner(tidx(1:n_samples),tprc,ladj(1:nadj),idxmap,info) + call psi_cpy_out(iprc,tprc,tsmpl,n_samples,k) + n_answers = n_answers + k + n_rest = nv - n_answers + nrest_max = n_rest + call psb_max(ictxt,nrest_max) + end do fnd_owner_loop + + else + call psi_a2a_fnd_owner(idx,iprc,idxmap,info) + end if call psb_erractionrestore(err_act) return @@ -126,4 +194,47 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info) return +contains + subroutine psi_get_sample(idx,tidx,tsmpl,ns_in,ns_out) + implicit none + integer(psb_lpk_), intent(in) :: idx(:) + integer(psb_ipk_), intent(in) :: ns_in + integer(psb_lpk_), intent(out) :: tidx(:) + integer(psb_ipk_), intent(out) :: tsmpl(:), ns_out + ! + integer(psb_ipk_) :: j, nv + + nv = size(idx) + ! + ! Choose a sample, should it be done in this simplistic way? + ! + ns_out = 0 + do j=1, nv + if (iprc(j) == -1) then + ns_out = ns_out + 1 + tsmpl(ns_out) = j + tidx(ns_out) = idx(j) + end if + if (ns_out >= ns_in) exit + end do + end subroutine psi_get_sample + + subroutine psi_cpy_out(iprc,tprc,tsmpl,ns_in,ns_out) + implicit none + integer(psb_ipk_), intent(out) :: iprc(:) + integer(psb_ipk_), intent(in) :: ns_in + integer(psb_ipk_), intent(in) :: tprc(:), tsmpl(:) + integer(psb_ipk_), intent(out) :: ns_out + + integer(psb_ipk_) :: j + + ns_out = 0 + do j=1, ns_in + if (tprc(j) /= -1) then + ns_out = ns_out + 1 + iprc(tsmpl(j)) = tprc(j) + end if + end do + end subroutine psi_cpy_out + end subroutine psi_graph_fnd_owner diff --git a/base/internals/psi_indx_map_fnd_owner.F90 b/base/internals/psi_indx_map_fnd_owner.F90 index 0e6e5f15..24d48509 100644 --- a/base/internals/psi_indx_map_fnd_owner.F90 +++ b/base/internals/psi_indx_map_fnd_owner.F90 @@ -60,10 +60,10 @@ subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info) #ifdef MPI_H include 'mpif.h' #endif - integer(psb_lpk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - class(psb_indx_map), intent(in) :: idxmap - integer(psb_ipk_), intent(out) :: info + class(psb_indx_map), intent(inout) :: idxmap + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), allocatable :: hhidx(:) @@ -134,8 +134,8 @@ subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info) else - if (.true.) then - + if (.false.) then + call psi_a2a_fnd_owner(idx,iprc,idxmap,info) else diff --git a/base/modules/desc/psb_desc_mod.F90 b/base/modules/desc/psb_desc_mod.F90 index 50f21808..f4984cd5 100644 --- a/base/modules/desc/psb_desc_mod.F90 +++ b/base/modules/desc/psb_desc_mod.F90 @@ -1746,10 +1746,10 @@ contains subroutine cd_fnd_owner(idx,iprc,desc,info) use psb_error_mod implicit none - integer(psb_lpk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - class(psb_desc_type), intent(in) :: desc - integer(psb_ipk_), intent(out) :: info + class(psb_desc_type), intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act character(len=20) :: name='cd_fnd_owner' logical, parameter :: debug=.false. diff --git a/base/modules/desc/psb_gen_block_map_mod.F90 b/base/modules/desc/psb_gen_block_map_mod.F90 index 15eb0939..575b89da 100644 --- a/base/modules/desc/psb_gen_block_map_mod.F90 +++ b/base/modules/desc/psb_gen_block_map_mod.F90 @@ -1934,10 +1934,10 @@ contains subroutine block_fnd_owner(idx,iprc,idxmap,info) use psb_penv_mod implicit none - integer(psb_lpk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - class(psb_gen_block_map), intent(in) :: idxmap - integer(psb_ipk_), intent(out) :: info + class(psb_gen_block_map), intent(inout) :: idxmap + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: ictxt, iam, np, nv, ip, i integer(psb_lpk_) :: tidx diff --git a/base/modules/desc/psb_glist_map_mod.f90 b/base/modules/desc/psb_glist_map_mod.f90 index fe585f1b..f360514f 100644 --- a/base/modules/desc/psb_glist_map_mod.f90 +++ b/base/modules/desc/psb_glist_map_mod.f90 @@ -154,10 +154,10 @@ contains use psb_penv_mod use psb_sort_mod implicit none - integer(psb_lpk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - class(psb_glist_map), intent(in) :: idxmap - integer(psb_ipk_), intent(out) :: info + class(psb_glist_map), intent(inout) :: idxmap + integer(psb_ipk_), intent(out) :: info integer(psb_mpk_) :: ictxt, iam, np integer(psb_lpk_) :: nv, i, ngp diff --git a/base/modules/desc/psb_indx_map_mod.f90 b/base/modules/desc/psb_indx_map_mod.f90 index e197d145..318929db 100644 --- a/base/modules/desc/psb_indx_map_mod.f90 +++ b/base/modules/desc/psb_indx_map_mod.f90 @@ -270,10 +270,10 @@ module psb_indx_map_mod subroutine psi_indx_map_fnd_owner(idx,iprc,idxmap,info) import :: psb_indx_map, psb_ipk_, psb_lpk_ implicit none - integer(psb_lpk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - class(psb_indx_map), intent(in) :: idxmap - integer(psb_ipk_), intent(out) :: info + class(psb_indx_map), intent(inout) :: idxmap + integer(psb_ipk_), intent(out) :: info end subroutine psi_indx_map_fnd_owner end interface @@ -281,21 +281,22 @@ module psb_indx_map_mod subroutine psi_a2a_fnd_owner(idx,iprc,idxmap,info) import :: psb_indx_map, psb_ipk_, psb_lpk_ implicit none - integer(psb_lpk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - class(psb_indx_map), intent(in) :: idxmap - integer(psb_ipk_), intent(out) :: info + class(psb_indx_map), intent(in) :: idxmap + integer(psb_ipk_), intent(out) :: info end subroutine psi_a2a_fnd_owner end interface interface - subroutine psi_adjcncy_fnd_owner(idx,iprc,idxmap,info) + subroutine psi_adjcncy_fnd_owner(idx,iprc,ladj,idxmap,info) import :: psb_indx_map, psb_ipk_, psb_lpk_ implicit none - integer(psb_lpk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) + integer(psb_ipk_), intent(in) :: ladj(:) class(psb_indx_map), intent(in) :: idxmap - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psi_adjcncy_fnd_owner end interface @@ -303,10 +304,10 @@ module psb_indx_map_mod subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info) import :: psb_indx_map, psb_ipk_, psb_lpk_ implicit none - integer(psb_lpk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - class(psb_indx_map), intent(in) :: idxmap - integer(psb_ipk_), intent(out) :: info + class(psb_indx_map), intent(inout) :: idxmap + integer(psb_ipk_), intent(out) :: info end subroutine psi_graph_fnd_owner end interface diff --git a/base/modules/desc/psb_repl_map_mod.f90 b/base/modules/desc/psb_repl_map_mod.f90 index e68f8509..b874a134 100644 --- a/base/modules/desc/psb_repl_map_mod.f90 +++ b/base/modules/desc/psb_repl_map_mod.f90 @@ -699,10 +699,10 @@ contains subroutine repl_fnd_owner(idx,iprc,idxmap,info) use psb_penv_mod implicit none - integer(psb_lpk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - class(psb_repl_map), intent(in) :: idxmap - integer(psb_ipk_), intent(out) :: info + class(psb_repl_map), intent(inout) :: idxmap + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: nv integer(psb_mpk_) :: ictxt, iam, np diff --git a/base/modules/psi_i_mod.F90 b/base/modules/psi_i_mod.F90 index 099d62a4..e8222753 100644 --- a/base/modules/psi_i_mod.F90 +++ b/base/modules/psi_i_mod.F90 @@ -131,11 +131,11 @@ module psi_i_mod subroutine psi_i_fnd_owner(nv,idx,iprc,desc,info) import implicit none - integer(psb_ipk_), intent(in) :: nv - integer(psb_ipk_), intent(in) :: idx(:) + integer(psb_ipk_), intent(in) :: nv + integer(psb_ipk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - type(psb_desc_type), intent(in) :: desc - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type), intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info end subroutine psi_i_fnd_owner end interface psi_fnd_owner