Merge branch 'development' into maint-3.7.0

maint-3.7.0
Salvatore Filippone 4 years ago
commit 06a752ed68

@ -138,6 +138,9 @@ subroutine psi_a2a_fnd_owner(idx,iprc,idxmap,info,samesize)
call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate')
goto 9999 goto 9999
end if end if
#if defined(SERIAL_MPI)
iprc(:) = 0
#else
call mpi_allgather(idx,nv,psb_mpi_lpk_,rmtidx,nv,psb_mpi_lpk_,icomm,minfo) call mpi_allgather(idx,nv,psb_mpi_lpk_,rmtidx,nv,psb_mpi_lpk_,icomm,minfo)
call idxmap%g2l(rmtidx(1:gsz),lclidx(1:gsz),info,owned=.true.) call idxmap%g2l(rmtidx(1:gsz),lclidx(1:gsz),info,owned=.true.)
! !
@ -200,6 +203,7 @@ subroutine psi_a2a_fnd_owner(idx,iprc,idxmap,info,samesize)
write(0,*) me,' a2a_fnd: missing answers',count(iprc(1:hsz(me+1))<0),& write(0,*) me,' a2a_fnd: missing answers',count(iprc(1:hsz(me+1))<0),&
& gsz,hsz(me+1) & gsz,hsz(me+1)
end if end if
#endif
end if end if
end if end if

@ -143,6 +143,9 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_realloc') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_realloc')
goto 9999 goto 9999
end if end if
#if defined(SERIAL_MPI)
iprc(:) = 0
#else
iprc = -1 iprc = -1
xchg_alg = psi_get_adj_alg() xchg_alg = psi_get_adj_alg()
!if (me == 0) write(0,*) me,'adj_fnd_owner alg: ',xchg_alg,' Going through ',nidx,nadj !if (me == 0) write(0,*) me,'adj_fnd_owner alg: ',xchg_alg,' Going through ',nidx,nadj
@ -430,7 +433,7 @@ subroutine psi_adjcncy_fnd_owner(idx,iprc,adj,idxmap,info)
call psb_errpush(info,name,a_err='invalid exchange alg choice') call psb_errpush(info,name,a_err='invalid exchange alg choice')
goto 9999 goto 9999
end select end select
#endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

@ -150,6 +150,9 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
! !
nv = size(idx) nv = size(idx)
call psb_realloc(nv,iprc,info) call psb_realloc(nv,iprc,info)
#if defined(SERIAL_MPI)
iprc(:) = 0
#else
if (info == psb_success_) call psb_realloc(nv,tidx,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,tprc,info)
if (info == psb_success_) call psb_realloc(nv,tsmpl,info) if (info == psb_success_) call psb_realloc(nv,tsmpl,info)
@ -279,6 +282,7 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
if (trace.and.(me == 0)) write(0,*) ' fnd_owner_loop remaining:',nqries_max if (trace.and.(me == 0)) write(0,*) ' fnd_owner_loop remaining:',nqries_max
if (do_timings) call psb_toc(idx_loop_neigh) if (do_timings) call psb_toc(idx_loop_neigh)
end do fnd_owner_loop end do fnd_owner_loop
#endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -286,6 +290,7 @@ subroutine psi_graph_fnd_owner(idx,iprc,idxmap,info)
9999 call psb_error_handler(ctxt,err_act) 9999 call psb_error_handler(ctxt,err_act)
return return
#if !defined(SERIAL_MPI)
contains contains
@ -404,5 +409,5 @@ contains
! if (me == 0) write(0,*)'adj_fnd_sweep: sweeps: ',isw ! if (me == 0) write(0,*)'adj_fnd_sweep: sweeps: ',isw
end subroutine psi_adj_fnd_sweep end subroutine psi_adj_fnd_sweep
#endif
end subroutine psi_graph_fnd_owner end subroutine psi_graph_fnd_owner

@ -45,6 +45,7 @@ module mpi
integer(psb_mpk_), parameter :: mpi_character = 7 integer(psb_mpk_), parameter :: mpi_character = 7
integer(psb_mpk_), parameter :: mpi_logical = 8 integer(psb_mpk_), parameter :: mpi_logical = 8
integer(psb_mpk_), parameter :: mpi_integer2 = 9 integer(psb_mpk_), parameter :: mpi_integer2 = 9
integer(psb_mpk_), parameter :: mpi_integer4 = 10
integer(psb_mpk_), parameter :: mpi_comm_null = -1 integer(psb_mpk_), parameter :: mpi_comm_null = -1
integer(psb_mpk_), parameter :: mpi_comm_world = 1 integer(psb_mpk_), parameter :: mpi_comm_world = 1
@ -823,7 +824,7 @@ contains
call psb_set_debug_unit(psb_err_unit) call psb_set_debug_unit(psb_err_unit)
#if defined(SERIAL_MPI) #if defined(SERIAL_MPI)
ctxt = nctxt ctxt%ctxt = nctxt ! allocate on assignment
nctxt = nctxt + 1 nctxt = nctxt + 1
call psi_register_mpi_extras(info) call psi_register_mpi_extras(info)

@ -314,7 +314,11 @@ contains
! A nifty MPI function will split the process list ! A nifty MPI function will split the process list
npdims = 0 npdims = 0
#if defined(SERIAL_MPI)
npdims = 1
#else
call mpi_dims_create(np,2,npdims,info) call mpi_dims_create(np,2,npdims,info)
#endif
npx = npdims(1) npx = npdims(1)
npy = npdims(2) npy = npdims(2)

@ -330,7 +330,11 @@ contains
! A nifty MPI function will split the process list ! A nifty MPI function will split the process list
npdims = 0 npdims = 0
#if defined(SERIAL_MPI)
npdims = 1
#else
call mpi_dims_create(np,3,npdims,info) call mpi_dims_create(np,3,npdims,info)
#endif
npx = npdims(1) npx = npdims(1)
npy = npdims(2) npy = npdims(2)
npz = npdims(3) npz = npdims(3)

@ -314,7 +314,11 @@ contains
! A nifty MPI function will split the process list ! A nifty MPI function will split the process list
npdims = 0 npdims = 0
#if defined(SERIAL_MPI)
npdims = 1
#else
call mpi_dims_create(np,2,npdims,info) call mpi_dims_create(np,2,npdims,info)
#endif
npx = npdims(1) npx = npdims(1)
npy = npdims(2) npy = npdims(2)

@ -330,7 +330,11 @@ contains
! A nifty MPI function will split the process list ! A nifty MPI function will split the process list
npdims = 0 npdims = 0
#if defined(SERIAL_MPI)
npdims = 1
#else
call mpi_dims_create(np,3,npdims,info) call mpi_dims_create(np,3,npdims,info)
#endif
npx = npdims(1) npx = npdims(1)
npy = npdims(2) npy = npdims(2)
npz = npdims(3) npz = npdims(3)
Loading…
Cancel
Save