@ -70,7 +70,7 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
& sdsz ( : ) , sdidx ( : ) , rvsz ( : ) , rvidx ( : ) , answers ( : , : ) , idxsrch ( : , : )
& sdsz ( : ) , sdidx ( : ) , rvsz ( : ) , rvidx ( : ) , answers ( : , : ) , idxsrch ( : , : )
integer ( psb_ipk_ ) :: i , n_row , n_col , err_act , ih , icomm , hsize , ip , isz , k , j , &
integer ( psb_ipk_ ) :: i , n_row , n_col , err_act , ih , icomm , hsize , ip , isz , k , j , &
& last_ih , last_j , nv
& last_ih , last_j , nv , mglob , nresp
integer ( psb_ipk_ ) :: ictxt , np , me
integer ( psb_ipk_ ) :: ictxt , np , me
logical , parameter :: gettime = . false .
logical , parameter :: gettime = . false .
real ( psb_dpk_ ) :: t0 , t1 , t2 , t3 , t4 , tamx , tidx
real ( psb_dpk_ ) :: t0 , t1 , t2 , t3 , t4 , tamx , tidx
@ -82,12 +82,13 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
ictxt = idxmap % get_ctxt ( )
ictxt = idxmap % get_ctxt ( )
icomm = idxmap % get_mpic ( )
icomm = idxmap % get_mpic ( )
mglob = idxmap % get_gr ( )
n_row = idxmap % get_lr ( )
n_row = idxmap % get_lr ( )
n_col = idxmap % get_lc ( )
n_col = idxmap % get_lc ( )
call psb_info ( ictxt , me , np )
call psb_info ( ictxt , me , np )
if ( np == - 1 ) then
if ( np == - 1 ) then
info = psb_err_context_error_
info = psb_err_context_error_
call psb_errpush ( info , name )
call psb_errpush ( info , name )
@ -104,169 +105,197 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
end if
end if
nv = size ( idx )
nv = size ( idx )
!
call psb_realloc ( nv , iprc , info )
! The basic idea is very simple .
! First we collect ( to all ) all the requests .
Allocate ( hidx ( np + 1 ) , hsz ( np ) , &
& sdsz ( 0 : np - 1 ) , sdidx ( 0 : np - 1 ) , &
& rvsz ( 0 : np - 1 ) , rvidx ( 0 : np - 1 ) , &
& stat = info )
if ( info / = psb_success_ ) then
if ( info / = psb_success_ ) then
call psb_errpush ( psb_err_from_subroutine_ , name , a_err = ' Allocate')
call psb_errpush ( psb_err_from_subroutine_ , name , a_err = 'psb_realloc' )
go to 9999
go to 9999
end if
end if
hsz = 0
if ( associated ( idxmap % parts ) ) then
hsz ( me + 1 ) = nv
! Use function shortcut
call psb_amx ( ictxt , hsz )
! ! $ write ( 0 , * ) me , trim ( name ) , ' indxmap%parts shortcut'
hidx ( 1 ) = 0
Allocate ( hidx ( np ) , stat = info )
do i = 1 , np
if ( info / = psb_success_ ) then
hidx ( i + 1 ) = hidx ( i ) + hsz ( i )
call psb_errpush ( psb_err_from_subroutine_ , name , a_err = 'Allocate' )
end do
go to 9999
hsize = hidx ( np + 1 )
end if
Allocate ( helem ( hsize ) , hproc ( hsize ) , stat = info )
do i = 1 , nv
if ( info / = psb_success_ ) then
call idxmap % parts ( idx ( i ) , mglob , np , hidx , nresp )
call psb_errpush ( psb_err_from_subroutine_ , name , a_err = 'Allocate' )
if ( nresp > 0 ) then
go to 9999
iprc ( i ) = hidx ( 1 )
end if
else
iprc ( i ) = - 1
end if
end do
if ( gettime ) then
else if ( allocated ( idxmap % tempvg ) ) then
t3 = psb_wtime ( )
! ! $ write ( 0 , * ) me , trim ( name ) , ' indxmap%tempvg shortcut'
end if
! Use temporary vector
do i = 1 , nv
iprc ( i ) = idxmap % tempvg ( idx ( i ) )
end do
call mpi_allgatherv ( idx , hsz ( me + 1 ) , psb_mpi_integer , &
else
& hproc , hsz , hidx , psb_mpi_integer , &
& icomm , info )
if ( gettime ) then
tamx = psb_wtime ( ) - t3
end if
! Second , we figure out locally whether we own the indices ( whoever is
!
! asking for them ) .
! The basic idea is very simple .
if ( gettime ) then
! First we collect ( to all ) all the requests .
t3 = psb_wtime ( )
Allocate ( hidx ( np + 1 ) , hsz ( np ) , &
end if
& sdsz ( 0 : np - 1 ) , sdidx ( 0 : np - 1 ) , &
& rvsz ( 0 : np - 1 ) , rvidx ( 0 : np - 1 ) , &
& stat = info )
if ( info / = psb_success_ ) then
call psb_errpush ( psb_err_from_subroutine_ , name , a_err = 'Allocate' )
go to 9999
end if
call idxmap % g2l ( hproc ( 1 : hsize ) , helem ( 1 : hsize ) , info , owned = . true . )
hsz = 0
if ( gettime ) then
hsz ( me + 1 ) = nv
tidx = psb_wtime ( ) - t3
call psb_amx ( ictxt , hsz )
end if
hidx ( 1 ) = 0
if ( info == psb_err_iarray_outside_bounds_ ) info = psb_success_
do i = 1 , np
if ( info / = psb_success_ ) then
hidx ( i + 1 ) = hidx ( i ) + hsz ( i )
call psb_errpush ( psb_err_from_subroutine_ , name , a_err = 'psi_idx_cnv' )
end do
go to 9999
hsize = hidx ( np + 1 )
end if
Allocate ( helem ( hsize ) , hproc ( hsize ) , stat = info )
if ( info / = psb_success_ ) then
call psb_errpush ( psb_err_from_subroutine_ , name , a_err = 'Allocate' )
go to 9999
end if
! Third : we build the answers for those indices we own ,
if ( gettime ) then
! with a section for each process asking .
t3 = psb_wtime ( )
hidx = hidx + 1
end if
j = 0
do ip = 0 , np - 1
call mpi_allgatherv ( idx , hsz ( me + 1 ) , psb_mpi_integer , &
sdidx ( ip ) = j
& hproc , hsz , hidx , psb_mpi_integer , &
sdsz ( ip ) = 0
& icomm , info )
do i = hidx ( ip + 1 ) , hidx ( ip + 1 + 1 ) - 1
if ( gettime ) then
if ( ( 0 < helem ( i ) ) . and . ( helem ( i ) < = n_row ) ) then
tamx = psb_wtime ( ) - t3
j = j + 1
end if
hproc ( j ) = hproc ( i )
sdsz ( ip ) = sdsz ( ip ) + 1
! Second , we figure out locally whether we own the indices ( whoever is
end if
! asking for them ) .
if ( gettime ) then
t3 = psb_wtime ( )
end if
call idxmap % g2l ( hproc ( 1 : hsize ) , helem ( 1 : hsize ) , info , owned = . true . )
if ( gettime ) then
tidx = psb_wtime ( ) - t3
end if
if ( info == psb_err_iarray_outside_bounds_ ) info = psb_success_
if ( info / = psb_success_ ) then
call psb_errpush ( psb_err_from_subroutine_ , name , a_err = 'psi_idx_cnv' )
go to 9999
end if
! Third : we build the answers for those indices we own ,
! with a section for each process asking .
hidx = hidx + 1
j = 0
do ip = 0 , np - 1
sdidx ( ip ) = j
sdsz ( ip ) = 0
do i = hidx ( ip + 1 ) , hidx ( ip + 1 + 1 ) - 1
if ( ( 0 < helem ( i ) ) . and . ( helem ( i ) < = n_row ) ) then
j = j + 1
hproc ( j ) = hproc ( i )
sdsz ( ip ) = sdsz ( ip ) + 1
end if
end do
end do
end do
end do
if ( gettime ) then
if ( gettime ) then
t3 = psb_wtime ( )
t3 = psb_wtime ( )
end if
end if
! Collect all the answers with alltoallv ( need sizes )
! Collect all the answers with alltoallv ( need sizes )
call mpi_alltoall ( sdsz , 1 , psb_mpi_integer , rvsz , 1 , mpi_integer , icomm , info )
call mpi_alltoall ( sdsz , 1 , psb_mpi_integer , rvsz , 1 , mpi_integer , icomm , info )
isz = sum ( rvsz )
isz = sum ( rvsz )
allocate ( answers ( isz , 2 ) , idxsrch ( nv , 2 ) , stat = info )
allocate ( answers ( isz , 2 ) , idxsrch ( nv , 2 ) , stat = info )
if ( info / = psb_success_ ) then
if ( info / = psb_success_ ) then
call psb_errpush ( psb_err_from_subroutine_ , name , a_err = 'Allocate' )
call psb_errpush ( psb_err_from_subroutine_ , name , a_err = 'Allocate' )
go to 9999
go to 9999
end if
end if
j = 0
j = 0
do ip = 0 , np - 1
do ip = 0 , np - 1
rvidx ( ip ) = j
rvidx ( ip ) = j
j = j + rvsz ( ip )
j = j + rvsz ( ip )
end do
call mpi_alltoallv ( hproc , sdsz , sdidx , psb_mpi_integer , &
& answers ( : , 1 ) , rvsz , rvidx , psb_mpi_integer , &
& icomm , info )
if ( gettime ) then
tamx = psb_wtime ( ) - t3 + tamx
end if
j = 1
do ip = 0 , np - 1
do k = 1 , rvsz ( ip )
answers ( j , 2 ) = ip
j = j + 1
end do
end do
end do
call mpi_alltoallv ( hproc , sdsz , sdidx , psb_mpi_integer , &
! Sort the answers and the requests , so we can
& answers ( : , 1 ) , rvsz , rvidx , psb_mpi_integer , &
! match them efficiently
& icomm , info )
call psb_msort ( answers ( : , 1 ) , ix = answers ( : , 2 ) , &
if ( gettime ) then
& flag = psb_sort_keep_idx_ )
tamx = psb_wtime ( ) - t3 + tamx
idxsrch ( 1 : nv , 1 ) = idx ( 1 : nv )
end if
call psb_msort ( idxsrch ( 1 : nv , 1 ) , ix = idxsrch ( 1 : nv , 2 ) )
j = 1
do ip = 0 , np - 1
! Now extract the answers for our local query
do k = 1 , rvsz ( ip )
call psb_realloc ( nv , iprc , info )
answers ( j , 2 ) = ip
if ( info / = psb_success_ ) then
j = j + 1
call psb_errpush ( psb_err_from_subroutine_ , name , a_err = 'psb_realloc' )
end do
go to 9999
end do
end if
! Sort the answers and the requests , so we can
last_ih = - 1
! match them efficiently
last_j = - 1
call psb_msort ( answers ( : , 1 ) , ix = answers ( : , 2 ) , &
j = 1
& flag = psb_sort_keep_idx_ )
do i = 1 , nv
idxsrch ( 1 : nv , 1 ) = idx ( 1 : nv )
ih = idxsrch ( i , 1 )
call psb_msort ( idxsrch ( 1 : nv , 1 ) , ix = idxsrch ( 1 : nv , 2 ) )
if ( ih == last_ih ) then
iprc ( idxsrch ( i , 2 ) ) = answers ( last_j , 2 )
! Now extract the answers for our local query
else
last_ih = - 1
last_j = - 1
do
j = 1
if ( j > size ( answers , 1 ) ) then
do i = 1 , nv
! Last resort attempt .
ih = idxsrch ( i , 1 )
j = psb_ibsrch ( ih , size ( answers , 1 ) , answers ( : , 1 ) )
if ( ih == last_ih ) then
if ( j == - 1 ) then
iprc ( idxsrch ( i , 2 ) ) = answers ( last_j , 2 )
write ( psb_err_unit , * ) me , 'psi_fnd_owner: searching for ' , ih , &
else
& 'not found : ' , size ( answers , 1 ) , ':' , answers ( : , 1 )
info = psb_err_internal_error_
do
call psb_errpush ( psb_err_internal_error_ , name , a_err = 'out bounds srch ih' )
if ( j > size ( answers , 1 ) ) then
go to 9999
! Last resort attempt .
j = psb_ibsrch ( ih , size ( answers , 1 ) , answers ( : , 1 ) )
if ( j == - 1 ) then
write ( psb_err_unit , * ) me , 'psi_fnd_owner: searching for ' , ih , &
& 'not found : ' , size ( answers , 1 ) , ':' , answers ( : , 1 )
info = psb_err_internal_error_
call psb_errpush ( psb_err_internal_error_ , name , a_err = 'out bounds srch ih' )
go to 9999
end if
end if
end if
end if
if ( answers ( j , 1 ) == ih ) exit
if ( answers ( j , 1 ) == ih ) exit
if ( answers ( j , 1 ) > ih ) then
if ( answers ( j , 1 ) > ih ) then
k = j
k = j
j = psb_ibsrch ( ih , k , answers ( 1 : k , 1 ) )
j = psb_ibsrch ( ih , k , answers ( 1 : k , 1 ) )
if ( j == - 1 ) then
if ( j == - 1 ) then
write ( psb_err_unit , * ) me , 'psi_fnd_owner: searching for ' , ih , &
write ( psb_err_unit , * ) me , 'psi_fnd_owner: searching for ' , ih , &
& 'not found : ' , size ( answers , 1 ) , ':' , answers ( : , 1 )
& 'not found : ' , size ( answers , 1 ) , ':' , answers ( : , 1 )
info = psb_err_internal_error_
info = psb_err_internal_error_
call psb_errpush ( psb_err_internal_error_ , name , a_err = 'out bounds srch ih' )
call psb_errpush ( psb_err_internal_error_ , name , a_err = 'out bounds srch ih' )
go to 9999
goto 9999
end if
end if
end if
end if
j = j + 1
j = j + 1
end do
end do
! Note that the answers here are given in order
! Note that the answers here are given in order
! of sending process , so we are implicitly getting
! of sending process , so we are implicitly getting
! the max process index in case of overlap .
! the max process index in case of overlap .
last_ih = ih
last_ih = ih
do
do
last_j = j
last_j = j
iprc ( idxsrch ( i , 2 ) ) = answers ( j , 2 )
iprc ( idxsrch ( i , 2 ) ) = answers ( j , 2 )
j = j + 1
j = j + 1
if ( j > size ( answers , 1 ) ) exit
if ( j > size ( answers , 1 ) ) exit
if ( answers ( j , 1 ) / = ih ) exit
if ( answers ( j , 1 ) / = ih ) exit
end do
end do
end if
end if
end do
end do
end if
if ( gettime ) then
if ( gettime ) then
call psb_barrier ( ictxt )
call psb_barrier ( ictxt )