From 6732106bc270bd35179ba3fa243174e95eecb737 Mon Sep 17 00:00:00 2001
From: Salvatore Filippone <salvatore.filippone@cranfield.ac.uk>
Date: Fri, 1 Nov 2019 16:00:19 +0000
Subject: [PATCH] First version of adjncy_fnd_owner. To be fully tested.

---
 base/internals/psi_adjcncy_fnd_owner.F90 | 77 ++++++++++++++++++++++--
 base/internals/psi_graph_fnd_owner.F90   | 12 ++--
 2 files changed, 80 insertions(+), 9 deletions(-)

diff --git a/base/internals/psi_adjcncy_fnd_owner.F90 b/base/internals/psi_adjcncy_fnd_owner.F90
index 9c989c21..1995253d 100644
--- a/base/internals/psi_adjcncy_fnd_owner.F90
+++ b/base/internals/psi_adjcncy_fnd_owner.F90
@@ -67,8 +67,8 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,ladj,idxmap,info)
   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(:,:), rmtidx(:)
+  integer(psb_ipk_), allocatable :: tproc(:), lclidx(:)
   integer(psb_mpk_), allocatable :: hsz(:),hidx(:), &
        & sdsz(:),sdidx(:), rvsz(:), rvidx(:)
   integer(psb_mpk_) :: icomm, minfo, iictxt
@@ -114,10 +114,77 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,ladj,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)
+  iprc = -1
+  ! write(0,*) me,name,' Going through ',nv,size(ladj)
+
+  Allocate(hidx(0:np),hsz(np),&
+       & sdsz(0:np-1),sdidx(0:np-1),&
+       & rvsz(0:np-1),rvidx(0:np-1),&
+       & stat=info)
+  !
+  ! First, send sizes according to adjcncy list
+  !
+  sdsz = 0 
+  do j=1, size(ladj)
+    sdsz(ladj(j)) = nv
+  end do
+  !write(0,*)me,' Check on sizes into a2a:',ladj(:),size(ladj),':',sdsz(:)
+  
+  call mpi_alltoall(sdsz,1,psb_mpi_mpk_,&
+       & rvsz,1,psb_mpi_mpk_,icomm,minfo)
+  hidx(0)   = 0
+  do i=0, np-1
+    hidx(i+1) = hidx(i) + rvsz(i)
+  end do
+  hsize = hidx(np)
+  write(0,*)me,' Check on sizes from a2a:',hsize,rvsz(:)
+  !
+  ! Second, allocate buffers and exchange data
+  !
+  Allocate(rmtidx(hsize),lclidx(hsize),tproc(max(hsize,nv)),stat=info)
+  
+  if (info /= psb_success_) then 
+    call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
+    goto 9999      
+  end if
+  do j=1, size(ladj)
+    write(0,*) me, ' First send to ',ladj(j),nv
+    if (nv > 0) call psb_snd(ictxt,idx(1:nv),ladj(j))
+  end do
+  do i = 0, np-1
+    if (rvsz(i)>0) then
+      write(0,*) me, ' First receive from ',i,rvsz(i)           
+      call psb_rcv(ictxt,rmtidx(hidx(i)+1:hidx(i)+rvsz(i)),i)
+    end if
+  end do
   
-  call psi_a2a_fnd_owner(idx,iprc,idxmap,info)
-  if (info /= psb_success_) goto 9999
+  !
+  ! Third, compute local answers
+  !
+  call idxmap%g2l(rmtidx(1:hsize),lclidx(1:hsize),info,owned=.true.)
+  do i=1, hsize
+    tproc(i) = -1
+    if ((0 < lclidx(i)).and. (lclidx(i) <= n_row)) tproc(i) = me
+  end do
+      
+  !
+  ! Fourth, send data back; 
+  !
+  do i = 0, np-1
+    if (rvsz(i)>0) then
+      write(0,*) me, ' Second send to ',i,rvsz(i)
+      call psb_snd(ictxt,tproc(hidx(i)+1:hidx(i)+rvsz(i)),i)
+    end if
+  end do
+  !
+  ! Fifth: receive and combine. MAX works because default
+  ! answer is -1. Reuse tproc
+  !
+  do j = 1, size(ladj)
+    write(0,*) me, ' Second receive from ',ladj(j), nv          
+    if (nv > 0) call psb_rcv(ictxt,tproc(1:nv),ladj(j))
+    iprc(1:nv) = max(iprc(1:nv), tproc(1:nv))
+  end do
   
   call psb_erractionrestore(err_act)
   return
diff --git a/base/internals/psi_graph_fnd_owner.F90 b/base/internals/psi_graph_fnd_owner.F90
index fa61d1b0..99f90fab 100644
--- a/base/internals/psi_graph_fnd_owner.F90
+++ b/base/internals/psi_graph_fnd_owner.F90
@@ -144,8 +144,10 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
       !
       ! Choose a sample, should it be done in this simplistic way? 
       !
-      call psi_get_sample(idx,tidx,tsmpl,n_samples,k)      
+      write(0,*) me,' Into first sampling ',n_samples
+      call psi_get_sample(idx,iprc,tidx,tsmpl,n_samples,k)      
       n_samples = min(k,n_samples)
+      write(0,*) me,' From first sampling ',n_samples
       ! 
       ! 2. Do a search on all processes; this is supposed to find
       !    the owning process for all inputs;
@@ -174,8 +176,10 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
       !    (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)      
+      write(0,*) me,' Into second sampling ',n_samples
+      call psi_get_sample(idx,iprc,tidx,tsmpl,n_samples,k)      
       n_samples = min(k,n_samples)
+      write(0,*) me,' From second sampling ',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
@@ -195,10 +199,10 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
   return
 
 contains
-  subroutine psi_get_sample(idx,tidx,tsmpl,ns_in,ns_out)      
+  subroutine psi_get_sample(idx,iprc,tidx,tsmpl,ns_in,ns_out)      
     implicit none
     integer(psb_lpk_), intent(in)  :: idx(:)
-    integer(psb_ipk_), intent(in)  :: ns_in
+    integer(psb_ipk_), intent(in)  :: ns_in, iprc(:)
     integer(psb_lpk_), intent(out) :: tidx(:)
     integer(psb_ipk_), intent(out) :: tsmpl(:), ns_out
     !