fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Added CAF collective subroutines and matdist

Browse Source
psblas3-caf
Ambra Abdullahi 8 years ago
parent 50d57a1acf
commit bcc9a0f39a
47 changed files with 4780 additions and 2998 deletions
Show Stats Download Patch File Download Diff File

10
base/comm/internals/psi_cswapdata.F90
Unescape Escape View File

@ -89,6 +89,7 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -142,7 +143,7 @@ subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data)
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
else else
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_xchg,info) call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_xchg,info)
@ -188,7 +189,6 @@ subroutine psi_cswap_xchg_m(iictxt,iicomm,flag,m,beta,y,xchg,info)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
print*,' call psi_cswap_xchg_m'
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -755,6 +755,7 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -808,7 +809,7 @@ subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
else else
call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info) call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info)
@ -1374,6 +1375,7 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -1428,7 +1430,7 @@ subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
else else
call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info) call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info)

10
base/comm/internals/psi_cswaptran.F90
Unescape Escape View File

@ -93,6 +93,7 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -147,7 +148,7 @@ subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
else else
call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_xchg,info) call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_xchg,info)
@ -756,6 +757,7 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -809,7 +811,7 @@ subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
else else
call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info) call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info)
@ -855,7 +857,6 @@ subroutine psi_cswaptran_xchg_v(iictxt,iicomm,flag,beta,y,xchg,info)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
print*,' call psi_dswaptran_xchg_v'
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -1393,6 +1394,7 @@ subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -1447,7 +1449,7 @@ subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
else else
call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info) call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info)

14
base/comm/internals/psi_dswapdata.F90
Unescape Escape View File

@ -89,6 +89,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -142,7 +143,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
else else
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_xchg,info) call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_xchg,info)
@ -190,7 +191,6 @@ subroutine psi_dswap_xchg_m(iictxt,iicomm,flag,m,beta,y,xchg,info)
info=psb_success_ info=psb_success_
name='psi_swap_xchg_m' name='psi_swap_xchg_m'
print*,me
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt ictxt = iictxt
icomm = iicomm icomm = iicomm
@ -755,6 +755,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -808,7 +809,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
else else
call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info) call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info)
@ -856,7 +857,6 @@ subroutine psi_dswap_xchg_v(iictxt,iicomm,flag,beta,y,xchg,info)
info=psb_success_ info=psb_success_
name='psi_swap_xchg_v' name='psi_swap_xchg_v'
print*, name
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt ictxt = iictxt
icomm = iicomm icomm = iicomm
@ -1375,6 +1375,7 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -1429,7 +1430,7 @@ subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
else else
call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info) call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info)
@ -1478,7 +1479,6 @@ subroutine psi_dswap_xchg_vect(iictxt,iicomm,flag,beta,y,xchg,info)
info=psb_success_ info=psb_success_
name='psi_xchg_vect' name='psi_xchg_vect'
print*,name
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt ictxt = iictxt
icomm = iicomm icomm = iicomm
@ -1533,9 +1533,7 @@ subroutine psi_dswap_xchg_vect(iictxt,iicomm,flag,beta,y,xchg,info)
! !
if (allocated(buffer)) deallocate(buffer) if (allocated(buffer)) deallocate(buffer)
!write(*,*) 'Allocating buffer',xchg%max_buffer_size !write(*,*) 'Allocating buffer',xchg%max_buffer_size
print*,'allocating buffer', me
allocate(buffer(xchg%max_buffer_size)[*],stat=info) allocate(buffer(xchg%max_buffer_size)[*],stat=info)
print*,'buffer allocated', me
if (allocated(sndbuf)) deallocate(sndbuf) if (allocated(sndbuf)) deallocate(sndbuf)
if (info == 0) allocate(sndbuf(xchg%max_buffer_size),stat=info) if (info == 0) allocate(sndbuf(xchg%max_buffer_size),stat=info)
if (info /= 0) then if (info /= 0) then

13
base/comm/internals/psi_dswaptran.F90
Unescape Escape View File

@ -93,6 +93,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -147,7 +148,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
else else
call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_xchg,info) call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_xchg,info)
@ -195,7 +196,6 @@ subroutine psi_dswaptran_xchg_m(iictxt,iicomm,flag,m,beta,y,xchg,info)
info=psb_success_ info=psb_success_
name='psi_swaptran_datam' name='psi_swaptran_datam'
print*,name
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt ictxt = iictxt
icomm = iicomm icomm = iicomm
@ -757,6 +757,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -810,7 +811,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
else else
call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info) call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info)
@ -856,10 +857,8 @@ subroutine psi_dswaptran_xchg_v(iictxt,iicomm,flag,beta,y,xchg,info)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
print*,' call psi_dswaptran_xchg_v'
info=psb_success_ info=psb_success_
name='psi_swaptran_xchg_v' name='psi_swaptran_xchg_v'
print*,name
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt ictxt = iictxt
icomm = iicomm icomm = iicomm
@ -1395,6 +1394,7 @@ subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -1449,7 +1449,7 @@ subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
else else
call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info) call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info)
@ -1498,7 +1498,6 @@ subroutine psi_dswaptran_xchg_vect(iictxt,iicomm,flag,beta,y,xchg,info)
info=psb_success_ info=psb_success_
name='psi_tran_xchg_vect' name='psi_tran_xchg_vect'
print*,name
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
ictxt = iictxt ictxt = iictxt
icomm = iicomm icomm = iicomm

548
base/comm/internals/psi_iswapdata.F90
Unescape Escape View File

@ -89,6 +89,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -107,6 +108,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
class(psb_xch_idx_type), pointer :: d_xchg
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -134,14 +136,19 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_ data_ = psb_comm_halo_
end if end if
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info == 0) call desc_a%get_list(data_,d_xchg,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.not.(if_caf2)) then
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
else
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_xchg,info)
endif
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -152,6 +159,174 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
return return
end subroutine psi_iswapdatam end subroutine psi_iswapdatam
subroutine psi_iswap_xchg_m(iictxt,iicomm,flag,m,beta,y,xchg,info)
use psi_mod, psb_protect_name => psi_iswap_xchg_m
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
use psb_penv_mod
use psb_i_base_vect_mod
use iso_fortran_env
implicit none
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag, m
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: y(:,:)
integer(psb_ipk_) :: beta
class(psb_xch_idx_type), intent(inout) :: xchg
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, iret
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,p1,p2,isz,rp1,rp2,&
& snd_pt, rcv_pt, pnti, n, ip, img, nxch, myself
integer :: count
integer(psb_ipk_), allocatable, save :: buffer(:)[:], sndbuf(:)
type(event_type), allocatable, save :: ufg(:)[:]
type(event_type), allocatable, save :: clear[:]
integer, save :: last_clear_count = 0
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
n=1
swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
if (.not.(do_send.and.do_recv)) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Unimplemented case in xchg_vect')
goto 9999
end if
if (.not.allocated(ufg)) then
!write(*,*) 'Allocating events',np
allocate(ufg(np)[*],stat=info)
if (info == 0) allocate(clear[*],stat=info)
if (info /= 0) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Coarray events allocation')
goto 9999
end if
else
if (last_clear_count>0) &
& event wait(clear,until_count=last_clear_count)
end if
if (psb_size(buffer) < xchg%max_buffer_size) then
!
! By construction, max_buffer_size was computed with a collective.
!
if (allocated(buffer)) deallocate(buffer)
if (allocated(sndbuf)) deallocate(sndbuf)
!write(*,*) 'Allocating buffer',xchg%max_buffer_size
allocate(buffer(xchg%max_buffer_size)[*],stat=info)
if (info == 0) allocate(sndbuf(xchg%max_buffer_size),stat=info)
if (info /= 0) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Coarray buffer allocation')
goto 9999
end if
end if
if (.false.) then
nxch = size(xchg%prcs_xch)
myself = this_image()
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_snd_bnd(ip)
p2 = xchg%loc_snd_bnd(ip+1)-1
rp1 = xchg%rmt_rcv_bnd(ip,1)
rp2 = xchg%rmt_rcv_bnd(ip,2)
isz = p2-p1+1
!write(0,*) myself,'Posting for ',img,' boundaries: ',p1,p2
call psi_gth(isz,m,xchg%loc_snd_idx(p1:p2),y,buffer(p1:p2))
event post(ufg(myself)[img])
end do
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
event wait(ufg(img))
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_rcv_bnd(ip)
p2 = xchg%loc_rcv_bnd(ip+1)-1
isz = p2-p1+1
rp1 = xchg%rmt_snd_bnd(ip,1)
rp2 = xchg%rmt_snd_bnd(ip,2)
!write(0,*) myself,'Getting from ',img,'Remote boundaries: ',rp1,rp2
call psi_sct(isz,m,xchg%loc_rcv_idx(p1:p2),buffer(rp1:rp2)[img],beta,y)
event post(clear[img])
end do
last_clear_count = nxch
else
nxch = size(xchg%prcs_xch)
myself = this_image()
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_snd_bnd(ip)
p2 = xchg%loc_snd_bnd(ip+1)-1
rp1 = xchg%rmt_rcv_bnd(ip,1)
rp2 = xchg%rmt_rcv_bnd(ip,2)
isz = p2-p1+1
call psi_gth(isz,m,xchg%loc_snd_idx(p1:p2),&
& y,sndbuf(p1:p2))
buffer(rp1:rp2)[img] = sndbuf(p1:p2)
end do
!
! Doing event post later should provide more opportunities for
! overlap
!
do ip= 1, nxch
img = xchg%prcs_xch(ip) + 1
event post(ufg(myself)[img])
end do
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
event wait(ufg(img))
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_rcv_bnd(ip)
p2 = xchg%loc_rcv_bnd(ip+1)-1
isz = p2-p1+1
rp1 = xchg%rmt_snd_bnd(ip,1)
rp2 = xchg%rmt_snd_bnd(ip,2)
!write(0,*) myself,'Getting from ',img,' boundaries: ',p1,p2
call psi_sct(isz,m,xchg%loc_rcv_idx(p1:p2),&
& buffer(p1:p2),beta, y)
event post(clear[img])
end do
last_clear_count = nxch
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psi_iswap_xchg_m
subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, &
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
@ -580,6 +755,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -598,6 +774,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
class(psb_xch_idx_type), pointer :: d_xchg
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -626,13 +803,20 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
data_ = psb_comm_halo_ data_ = psb_comm_halo_
end if end if
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info == 0) call desc_a%get_list(data_,d_xchg,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) if (.not.(if_caf2)) then
call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
else
call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info)
endif
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -644,6 +828,173 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
end subroutine psi_iswapdatav end subroutine psi_iswapdatav
subroutine psi_iswap_xchg_v(iictxt,iicomm,flag,beta,y,xchg,info)
use psi_mod, psb_protect_name => psi_iswap_xchg_v
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
use psb_penv_mod
use psb_i_base_vect_mod
use iso_fortran_env
implicit none
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: y(:)
integer(psb_ipk_) :: beta
class(psb_xch_idx_type), intent(inout) :: xchg
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, iret
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,p1,p2,isz,rp1,rp2,&
& snd_pt, rcv_pt, pnti, n, ip, img, nxch, myself
integer :: count
integer(psb_ipk_), allocatable, save :: buffer(:)[:], sndbuf(:)
type(event_type), allocatable, save :: ufg(:)[:]
type(event_type), allocatable, save :: clear[:]
integer, save :: last_clear_count = 0
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
n=1
swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
if (.not.(do_send.and.do_recv)) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Unimplemented case in xchg_vect')
goto 9999
end if
if (.not.allocated(ufg)) then
!write(*,*) 'Allocating events',np
allocate(ufg(np)[*],stat=info)
if (info == 0) allocate(clear[*],stat=info)
if (info /= 0) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Coarray events allocation')
goto 9999
end if
else
if (last_clear_count>0) &
& event wait(clear,until_count=last_clear_count)
end if
if (psb_size(buffer) < xchg%max_buffer_size) then
!
! By construction, max_buffer_size was computed with a collective.
!
if (allocated(buffer)) deallocate(buffer)
if (allocated(sndbuf)) deallocate(sndbuf)
!write(*,*) 'Allocating buffer',xchg%max_buffer_size
allocate(buffer(xchg%max_buffer_size)[*],stat=info)
if (info == 0) allocate(sndbuf(xchg%max_buffer_size),stat=info)
if (info /= 0) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Coarray buffer allocation')
goto 9999
end if
end if
if (.false.) then
nxch = size(xchg%prcs_xch)
myself = this_image()
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_snd_bnd(ip)
p2 = xchg%loc_snd_bnd(ip+1)-1
rp1 = xchg%rmt_rcv_bnd(ip,1)
rp2 = xchg%rmt_rcv_bnd(ip,2)
isz = p2-p1+1
!write(0,*) myself,'Posting for ',img,' boundaries: ',p1,p2
call psi_gth(isz,xchg%loc_snd_idx(p1:p2),y,buffer(p1:p2))
event post(ufg(myself)[img])
end do
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
event wait(ufg(img))
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_rcv_bnd(ip)
p2 = xchg%loc_rcv_bnd(ip+1)-1
isz = p2-p1+1
rp1 = xchg%rmt_snd_bnd(ip,1)
rp2 = xchg%rmt_snd_bnd(ip,2)
!write(0,*) myself,'Getting from ',img,'Remote boundaries: ',rp1,rp2
call psi_sct(isz,xchg%loc_rcv_idx(p1:p2),buffer(rp1:rp2)[img],beta,y)
event post(clear[img])
end do
last_clear_count = nxch
else
nxch = size(xchg%prcs_xch)
myself = this_image()
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_snd_bnd(ip)
p2 = xchg%loc_snd_bnd(ip+1)-1
rp1 = xchg%rmt_rcv_bnd(ip,1)
rp2 = xchg%rmt_rcv_bnd(ip,2)
isz = p2-p1+1
call psi_gth(isz,xchg%loc_snd_idx(p1:p2),&
& y,sndbuf(p1:p2))
buffer(rp1:rp2)[img] = sndbuf(p1:p2)
end do
!
! Doing event post later should provide more opportunities for
! overlap
!
do ip= 1, nxch
img = xchg%prcs_xch(ip) + 1
event post(ufg(myself)[img])
end do
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
event wait(ufg(img))
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_rcv_bnd(ip)
p2 = xchg%loc_rcv_bnd(ip+1)-1
isz = p2-p1+1
rp1 = xchg%rmt_snd_bnd(ip,1)
rp2 = xchg%rmt_snd_bnd(ip,2)
!write(0,*) myself,'Getting from ',img,' boundaries: ',p1,p2
call psi_sct(isz,xchg%loc_rcv_idx(p1:p2),&
& buffer(p1:p2),beta, y)
event post(clear[img])
end do
last_clear_count = nxch
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psi_iswap_xchg_v
! !
! !
@ -1026,6 +1377,7 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -1045,6 +1397,7 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act
class(psb_i_base_vect_type), pointer :: d_vidx class(psb_i_base_vect_type), pointer :: d_vidx
class(psb_xch_idx_type), pointer :: d_xchg
character(len=20) :: name character(len=20) :: name
info=psb_success_ info=psb_success_
@ -1074,12 +1427,18 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
end if end if
call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info)
if (info == 0) call desc_a%get_list(data_,d_xchg,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (.not.(if_caf2)) then
call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
else
call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info)
endif
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -1090,6 +1449,187 @@ subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data)
return return
end subroutine psi_iswapdata_vect end subroutine psi_iswapdata_vect
subroutine psi_iswap_xchg_vect(iictxt,iicomm,flag,beta,y,xchg,info)
use psi_mod, psb_protect_name => psi_iswap_xchg_vect
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
use psb_penv_mod
use psb_i_base_vect_mod
use iso_fortran_env
implicit none
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
class(psb_xch_idx_type), intent(inout) :: xchg
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, iret
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,p1,p2,isz,rp1,rp2,&
& snd_pt, rcv_pt, pnti, n, ip, img, nxch, myself
integer :: count
integer(psb_ipk_), allocatable, save :: buffer(:)[:], sndbuf(:)
type(event_type), allocatable, save :: ufg(:)[:]
type(event_type), allocatable, save :: clear[:]
integer, save :: last_clear_count = 0
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info=psb_success_
name='psi_xchg_vect'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (np /= num_images()) then
write(*,*) 'Something is wrong MPI vs CAF ', np, num_images()
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Num_images /= np')
goto 9999
end if
n=1
swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
if (.not.(do_send.and.do_recv)) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Unimplemented case in xchg_vect')
goto 9999
end if
if (.not.allocated(ufg)) then
!write(*,*) 'Allocating events',np
allocate(ufg(np)[*],stat=info)
if (info == 0) allocate(clear[*],stat=info)
if (info /= 0) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Coarray events allocation')
goto 9999
end if
else
if (last_clear_count>0) &
& event wait(clear,until_count=last_clear_count)
end if
me = this_image()
if (psb_size(buffer) < xchg%max_buffer_size) then
!
! By construction, max_buffer_size was computed with a collective.
!
if (allocated(buffer)) deallocate(buffer)
!write(*,*) 'Allocating buffer',xchg%max_buffer_size, me
allocate(buffer(xchg%max_buffer_size)[*],stat=info)
if (allocated(sndbuf)) deallocate(sndbuf)
if (info == 0) allocate(sndbuf(xchg%max_buffer_size),stat=info)
if (info /= 0) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Coarray buffer allocation')
goto 9999
end if
end if
if (.false.) then
!sync all
nxch = size(xchg%prcs_xch)
myself = this_image()
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_snd_bnd(ip)
p2 = xchg%loc_snd_bnd(ip+1)-1
rp1 = xchg%rmt_rcv_bnd(ip,1)
rp2 = xchg%rmt_rcv_bnd(ip,2)
isz = p2-p1+1
!write(0,*) myself,'Posting for ',img,' boundaries: ',p1,p2
call y%gth(isz,xchg%loc_snd_idx(p1:p2),buffer(p1:p2))
event post(ufg(myself)[img])
end do
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
event wait(ufg(img))
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_rcv_bnd(ip)
p2 = xchg%loc_rcv_bnd(ip+1)-1
isz = p2-p1+1
rp1 = xchg%rmt_snd_bnd(ip,1)
rp2 = xchg%rmt_snd_bnd(ip,2)
!write(0,*) myself,'Getting from ',img,'Remote boundaries: ',rp1,rp2
call y%sct(isz,xchg%loc_rcv_idx(p1:p2),buffer(rp1:rp2)[img],beta)
event post(clear[img])
end do
last_clear_count = nxch
else
nxch = size(xchg%prcs_xch)
myself = this_image()
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_snd_bnd(ip)
p2 = xchg%loc_snd_bnd(ip+1)-1
rp1 = xchg%rmt_rcv_bnd(ip,1)
rp2 = xchg%rmt_rcv_bnd(ip,2)
isz = p2-p1+1
!write(0,*) myself,'Posting for ',img,' boundaries: ',rp1,rp2
if (.false.) then
call y%gth(isz,xchg%loc_snd_idx(p1:p2),buffer(rp1:rp2)[img])
else
call y%gth(isz,xchg%loc_snd_idx(p1:p2),sndbuf(p1:p2))
buffer(rp1:rp2)[img] = sndbuf(p1:p2)
end if
end do
!
! Doing event post later should provide more opportunities for
! overlap
!
do ip= 1, nxch
img = xchg%prcs_xch(ip) + 1
event post(ufg(myself)[img])
end do
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
event wait(ufg(img))
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_rcv_bnd(ip)
p2 = xchg%loc_rcv_bnd(ip+1)-1
isz = p2-p1+1
rp1 = xchg%rmt_snd_bnd(ip,1)
rp2 = xchg%rmt_snd_bnd(ip,2)
!write(0,*) myself,'Getting from ',img,' boundaries: ',p1,p2
call y%sct(isz,xchg%loc_rcv_idx(p1:p2),buffer(p1:p2),beta)
event post(clear[img])
end do
last_clear_count = nxch
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psi_iswap_xchg_vect
! !
! !

544
base/comm/internals/psi_iswaptran.F90
Unescape Escape View File

@ -93,6 +93,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -111,6 +112,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
class(psb_xch_idx_type), pointer :: d_xchg
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
@ -141,12 +143,17 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
end if end if
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info == 0) call desc_a%get_list(data_,d_xchg,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.not.(if_caf2)) then
call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
else
call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_xchg,info)
endif
call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -157,6 +164,174 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
return return
end subroutine psi_iswaptranm end subroutine psi_iswaptranm
subroutine psi_iswaptran_xchg_m(iictxt,iicomm,flag,m,beta,y,xchg,info)
use psi_mod, psb_protect_name => psi_iswaptran_xchg_m
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
use psb_penv_mod
use psb_i_base_vect_mod
use iso_fortran_env
implicit none
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag, m
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: y(:,:)
integer(psb_ipk_) :: beta
class(psb_xch_idx_type), intent(inout) :: xchg
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, iret
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,p1,p2,isz,rp1,rp2,&
& snd_pt, rcv_pt, pnti, n, ip, img, nxch, myself
integer :: count
integer(psb_ipk_), allocatable, save :: buffer(:)[:], sndbuf(:)
type(event_type), allocatable, save :: ufg(:)[:]
type(event_type), allocatable, save :: clear[:]
integer, save :: last_clear_count = 0
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info=psb_success_
name='psi_swaptran_datam'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
n=1
swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
if (.not.(do_send.and.do_recv)) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Unimplemented case in tran_xchg_vm')
goto 9999
end if
if (.not.allocated(ufg)) then
!write(*,*) 'Allocating events',np
allocate(ufg(np)[*],stat=info)
if (info == 0) allocate(clear[*],stat=info)
if (info /= 0) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Coarray events allocation')
goto 9999
end if
else
if (last_clear_count>0) &
& event wait(clear,until_count=last_clear_count)
end if
if (psb_size(buffer) < xchg%max_buffer_size) then
!
! By construction, max_buffer_size was computed with a collective.
!
if (allocated(buffer)) deallocate(buffer)
if (allocated(sndbuf)) deallocate(sndbuf)
!write(*,*) 'Allocating buffer',xchg%max_buffer_size
allocate(buffer(xchg%max_buffer_size)[*],stat=info)
if (info == 0) allocate(sndbuf(xchg%max_buffer_size),stat=info)
if (info /= 0) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Coarray buffer allocation')
goto 9999
end if
end if
if (.false.) then
nxch = size(xchg%prcs_xch)
myself = this_image()
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_rcv_bnd(ip)
p2 = xchg%loc_rcv_bnd(ip+1)-1
rp1 = xchg%rmt_snd_bnd(ip,1)
rp2 = xchg%rmt_snd_bnd(ip,2)
isz = p2-p1+1
!write(0,*) myself,'Posting for ',img,' boundaries: ',p1,p2
call psi_gth(isz,m,xchg%loc_rcv_idx(p1:p2),y,buffer(p1:p2))
event post(ufg(myself)[img])
end do
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
event wait(ufg(img))
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_snd_bnd(ip)
p2 = xchg%loc_snd_bnd(ip+1)-1
isz = p2-p1+1
rp1 = xchg%rmt_rcv_bnd(ip,1)
rp2 = xchg%rmt_rcv_bnd(ip,2)
!write(0,*) myself,'Getting from ',img,'Remote boundaries: ',rp1,rp2
call psi_sct(isz,m,xchg%loc_snd_idx(p1:p2),buffer(rp1:rp2)[img],beta,y)
event post(clear[img])
end do
last_clear_count = nxch
else
nxch = size(xchg%prcs_xch)
myself = this_image()
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_rcv_bnd(ip)
p2 = xchg%loc_rcv_bnd(ip+1)-1
rp1 = xchg%rmt_snd_bnd(ip,1)
rp2 = xchg%rmt_snd_bnd(ip,2)
isz = p2-p1+1
call psi_gth(isz,m,xchg%loc_rcv_idx(p1:p2),&
& y,sndbuf(p1:p2))
buffer(rp1:rp2)[img] = sndbuf(p1:p2)
end do
!
! Doing event post later should provide more opportunities for
! overlap
!
do ip= 1, nxch
img = xchg%prcs_xch(ip) + 1
event post(ufg(myself)[img])
end do
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
event wait(ufg(img))
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_snd_bnd(ip)
p2 = xchg%loc_snd_bnd(ip+1)-1
isz = p2-p1+1
rp1 = xchg%rmt_rcv_bnd(ip,1)
rp2 = xchg%rmt_rcv_bnd(ip,2)
!write(0,*) myself,'Getting from ',img,' boundaries: ',p1,p2
call psi_sct(isz,m,xchg%loc_snd_idx(p1:p2),&
& buffer(p1:p2),beta, y)
event post(clear[img])
end do
last_clear_count = nxch
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psi_iswaptran_xchg_m
subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_itranidxm use psi_mod, psb_protect_name => psi_itranidxm
@ -583,6 +758,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -601,6 +777,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
integer(psb_ipk_), pointer :: d_idx(:) integer(psb_ipk_), pointer :: d_idx(:)
class(psb_xch_idx_type), pointer :: d_xchg
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
@ -630,12 +807,18 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
end if end if
call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info)
if (info == 0) call desc_a%get_list(data_,d_xchg,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) if (.not.(if_caf2)) then
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
else
call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info)
endif
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -646,6 +829,172 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
return return
end subroutine psi_iswaptranv end subroutine psi_iswaptranv
subroutine psi_iswaptran_xchg_v(iictxt,iicomm,flag,beta,y,xchg,info)
use psi_mod, psb_protect_name => psi_iswaptran_xchg_v
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
use psb_penv_mod
use psb_i_base_vect_mod
use iso_fortran_env
implicit none
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: y(:)
integer(psb_ipk_) :: beta
class(psb_xch_idx_type), intent(inout) :: xchg
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, iret
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,p1,p2,isz,rp1,rp2,&
& snd_pt, rcv_pt, pnti, n, ip, img, nxch, myself
integer :: count
integer(psb_ipk_), allocatable, save :: buffer(:)[:], sndbuf(:)
type(event_type), allocatable, save :: ufg(:)[:]
type(event_type), allocatable, save :: clear[:]
integer, save :: last_clear_count = 0
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info=psb_success_
name='psi_swap_datav'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
n=1
swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
if (.not.(do_send.and.do_recv)) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Unimplemented case in xchg_vect')
goto 9999
end if
if (.not.allocated(ufg)) then
!write(*,*) 'Allocating events',np
allocate(ufg(np)[*],stat=info)
if (info == 0) allocate(clear[*],stat=info)
if (info /= 0) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Coarray events allocation')
goto 9999
end if
else
if (last_clear_count>0) &
& event wait(clear,until_count=last_clear_count)
end if
if (psb_size(buffer) < xchg%max_buffer_size) then
!
! By construction, max_buffer_size was computed with a collective.
!
if (allocated(buffer)) deallocate(buffer)
if (allocated(sndbuf)) deallocate(sndbuf)
!write(*,*) 'Allocating buffer',xchg%max_buffer_size
allocate(buffer(xchg%max_buffer_size)[*],stat=info)
if (info == 0) allocate(sndbuf(xchg%max_buffer_size),stat=info)
if (info /= 0) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Coarray buffer allocation')
goto 9999
end if
end if
if (.false.) then
nxch = size(xchg%prcs_xch)
myself = this_image()
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_rcv_bnd(ip)
p2 = xchg%loc_rcv_bnd(ip+1)-1
rp1 = xchg%rmt_snd_bnd(ip,1)
rp2 = xchg%rmt_snd_bnd(ip,2)
isz = p2-p1+1
!write(0,*) myself,'Posting for ',img,' boundaries: ',p1,p2
call psi_gth(isz,xchg%loc_rcv_idx(p1:p2),y,buffer(p1:p2))
event post(ufg(myself)[img])
end do
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
event wait(ufg(img))
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_snd_bnd(ip)
p2 = xchg%loc_snd_bnd(ip+1)-1
isz = p2-p1+1
rp1 = xchg%rmt_rcv_bnd(ip,1)
rp2 = xchg%rmt_rcv_bnd(ip,2)
!write(0,*) myself,'Getting from ',img,'Remote boundaries: ',rp1,rp2
call psi_sct(isz,xchg%loc_snd_idx(p1:p2),buffer(rp1:rp2)[img],beta,y)
event post(clear[img])
end do
last_clear_count = nxch
else
nxch = size(xchg%prcs_xch)
myself = this_image()
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_rcv_bnd(ip)
p2 = xchg%loc_rcv_bnd(ip+1)-1
rp1 = xchg%rmt_snd_bnd(ip,1)
rp2 = xchg%rmt_snd_bnd(ip,2)
isz = p2-p1+1
call psi_gth(isz,xchg%loc_rcv_idx(p1:p2),&
& y,sndbuf(p1:p2))
buffer(rp1:rp2)[img] = sndbuf(p1:p2)
end do
!
! Doing event post later should provide more opportunities for
! overlap
!
do ip= 1, nxch
img = xchg%prcs_xch(ip) + 1
event post(ufg(myself)[img])
end do
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
event wait(ufg(img))
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_snd_bnd(ip)
p2 = xchg%loc_snd_bnd(ip+1)-1
isz = p2-p1+1
rp1 = xchg%rmt_rcv_bnd(ip,1)
rp2 = xchg%rmt_rcv_bnd(ip,2)
!write(0,*) myself,'Getting from ',img,' boundaries: ',p1,p2
call psi_sct(isz,xchg%loc_snd_idx(p1:p2),&
& buffer(p1:p2),beta, y)
event post(clear[img])
end do
last_clear_count = nxch
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psi_iswaptran_xchg_v
! !
! !
@ -658,7 +1007,6 @@ end subroutine psi_iswaptranv
! !
! !
subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info)
use psi_mod, psb_protect_name => psi_itranidxv use psi_mod, psb_protect_name => psi_itranidxv
@ -1047,6 +1395,7 @@ subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -1066,6 +1415,7 @@ subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data)
! locals ! locals
integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_
class(psb_i_base_vect_type), pointer :: d_vidx class(psb_i_base_vect_type), pointer :: d_vidx
class(psb_xch_idx_type), pointer :: d_xchg
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
@ -1095,12 +1445,18 @@ subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data)
end if end if
call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info)
if (info == 0) call desc_a%get_list(data_,d_xchg,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) if (.not.(if_caf2)) then
call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
else
call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info)
endif
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -1112,7 +1468,187 @@ subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data)
end subroutine psi_iswaptran_vect end subroutine psi_iswaptran_vect
subroutine psi_iswaptran_xchg_vect(iictxt,iicomm,flag,beta,y,xchg,info)
use psi_mod, psb_protect_name => psi_iswaptran_xchg_vect
use psb_error_mod
use psb_realloc_mod
use psb_desc_mod
use psb_penv_mod
use psb_i_base_vect_mod
use iso_fortran_env
implicit none
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
class(psb_xch_idx_type), intent(inout) :: xchg
! locals
integer(psb_mpik_) :: ictxt, icomm, np, me,&
& proc_to_comm, p2ptag, iret
integer(psb_ipk_) :: nesd, nerv,&
& err_act, i, idx_pt, totsnd_, totrcv_,p1,p2,isz,rp1,rp2,&
& snd_pt, rcv_pt, pnti, n, ip, img, nxch, myself
integer :: count
integer(psb_ipk_), allocatable, save :: buffer(:)[:], sndbuf(:)
type(event_type), allocatable, save :: ufg(:)[:]
type(event_type), allocatable, save :: clear[:]
integer, save :: last_clear_count = 0
logical :: swap_mpi, swap_sync, swap_send, swap_recv,&
& albf,do_send,do_recv
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info=psb_success_
name='psi_tran_xchg_vect'
call psb_erractionsave(err_act)
ictxt = iictxt
icomm = iicomm
call psb_info(ictxt,me,np)
if (np == -1) then
info=psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (np /= num_images()) then
write(*,*) 'Something is wrong MPI vs CAF ', np, num_images()
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Num_images /= np')
goto 9999
end if
n=1
swap_mpi = iand(flag,psb_swap_mpi_) /= 0
swap_sync = iand(flag,psb_swap_sync_) /= 0
swap_send = iand(flag,psb_swap_send_) /= 0
swap_recv = iand(flag,psb_swap_recv_) /= 0
do_send = swap_mpi .or. swap_sync .or. swap_send
do_recv = swap_mpi .or. swap_sync .or. swap_recv
if (.not.(do_send.and.do_recv)) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Unimplemented case in xchg_vect')
goto 9999
end if
if (.not.allocated(ufg)) then
!write(*,*) 'Allocating events',np
allocate(ufg(np)[*],stat=info)
if (info == 0) allocate(clear[*],stat=info)
if (info /= 0) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Coarray events allocation')
goto 9999
end if
else
if (last_clear_count>0) &
& event wait(clear,until_count=last_clear_count)
end if
if (psb_size(buffer) < xchg%max_buffer_size) then
!
! By construction, max_buffer_size was computed with a collective.
!
if (allocated(buffer)) deallocate(buffer)
!write(*,*) 'Allocating buffer',xchg%max_buffer_size
allocate(buffer(xchg%max_buffer_size)[*],stat=info)
if (allocated(sndbuf)) deallocate(sndbuf)
if (info == 0) allocate(sndbuf(xchg%max_buffer_size),stat=info)
if (info /= 0) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Coarray buffer allocation')
goto 9999
end if
end if
if (.false.) then
!sync all
nxch = size(xchg%prcs_xch)
myself = this_image()
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_rcv_bnd(ip)
p2 = xchg%loc_rcv_bnd(ip+1)-1
rp1 = xchg%rmt_snd_bnd(ip,1)
rp2 = xchg%rmt_snd_bnd(ip,2)
isz = p2-p1+1
!write(0,*) myself,'Posting for ',img,' boundaries: ',p1,p2
call y%gth(isz,xchg%loc_rcv_idx(p1:p2),buffer(p1:p2))
event post(ufg(myself)[img])
end do
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
event wait(ufg(img))
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_snd_bnd(ip)
p2 = xchg%loc_snd_bnd(ip+1)-1
isz = p2-p1+1
rp1 = xchg%rmt_rcv_bnd(ip,1)
rp2 = xchg%rmt_rcv_bnd(ip,2)
!write(0,*) myself,'Getting from ',img,'Remote boundaries: ',rp1,rp2
call y%sct(isz,xchg%loc_snd_idx(p1:p2),buffer(rp1:rp2)[img],beta)
event post(clear[img])
end do
last_clear_count = nxch
else
nxch = size(xchg%prcs_xch)
myself = this_image()
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_rcv_bnd(ip)
p2 = xchg%loc_rcv_bnd(ip+1)-1
rp1 = xchg%rmt_snd_bnd(ip,1)
rp2 = xchg%rmt_snd_bnd(ip,2)
isz = p2-p1+1
!write(0,*) myself,'Posting for ',img,' boundaries: ',rp1,rp2
if (.false.) then
call y%gth(isz,xchg%loc_rcv_idx(p1:p2),buffer(rp1:rp2)[img])
else
call y%gth(isz,xchg%loc_rcv_idx(p1:p2),sndbuf(p1:p2))
buffer(rp1:rp2)[img] = sndbuf(p1:p2)
end if
end do
!
! Doing event post later should provide more opportunities for
! overlap
!
do ip= 1, nxch
img = xchg%prcs_xch(ip) + 1
event post(ufg(myself)[img])
end do
do ip = 1, nxch
img = xchg%prcs_xch(ip) + 1
event wait(ufg(img))
img = xchg%prcs_xch(ip) + 1
p1 = xchg%loc_snd_bnd(ip)
p2 = xchg%loc_snd_bnd(ip+1)-1
isz = p2-p1+1
rp1 = xchg%rmt_rcv_bnd(ip,1)
rp2 = xchg%rmt_rcv_bnd(ip,2)
!write(0,*) myself,'Getting from ',img,' boundaries: ',p1,p2
call y%sct(isz,xchg%loc_snd_idx(p1:p2),buffer(p1:p2),beta)
event post(clear[img])
end do
last_clear_count = nxch
end if
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psi_iswaptran_xchg_vect
! !
! !
! Subroutine: psi_itran_vidx_vect ! Subroutine: psi_itran_vidx_vect

10
base/comm/internals/psi_sswapdata.F90
Unescape Escape View File

@ -89,6 +89,7 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -142,7 +143,7 @@ subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data)
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
else else
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_xchg,info) call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_xchg,info)
@ -188,7 +189,6 @@ subroutine psi_sswap_xchg_m(iictxt,iicomm,flag,m,beta,y,xchg,info)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
print*,' call psi_sswap_xchg_m'
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -755,6 +755,7 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -808,7 +809,7 @@ subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
else else
call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info) call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info)
@ -1374,6 +1375,7 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -1428,7 +1430,7 @@ subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
else else
call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info) call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info)

10
base/comm/internals/psi_sswaptran.F90
Unescape Escape View File

@ -93,6 +93,7 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -147,7 +148,7 @@ subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
else else
call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_xchg,info) call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_xchg,info)
@ -756,6 +757,7 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -809,7 +811,7 @@ subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
else else
call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info) call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info)
@ -855,7 +857,6 @@ subroutine psi_sswaptran_xchg_v(iictxt,iicomm,flag,beta,y,xchg,info)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
print*,' call psi_dswaptran_xchg_v'
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -1393,6 +1394,7 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -1447,7 +1449,7 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
else else
call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info) call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info)

10
base/comm/internals/psi_zswapdata.F90
Unescape Escape View File

@ -89,6 +89,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -142,7 +143,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
else else
call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_xchg,info) call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_xchg,info)
@ -188,7 +189,6 @@ subroutine psi_zswap_xchg_m(iictxt,iicomm,flag,m,beta,y,xchg,info)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
print*,' call psi_zswap_xchg_m'
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -755,6 +755,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -808,7 +809,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
else else
call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info) call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info)
@ -1374,6 +1375,7 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -1428,7 +1430,7 @@ subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
else else
call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info) call psi_swapdata(ictxt,icomm,flag,beta,y,d_xchg,info)

10
base/comm/internals/psi_zswaptran.F90
Unescape Escape View File

@ -93,6 +93,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -147,7 +148,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info)
else else
call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_xchg,info) call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_xchg,info)
@ -756,6 +757,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -809,7 +811,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info)
else else
call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info) call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info)
@ -855,7 +857,6 @@ subroutine psi_zswaptran_xchg_v(iictxt,iicomm,flag,beta,y,xchg,info)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name character(len=20) :: name
print*,' call psi_dswaptran_xchg_v'
info=psb_success_ info=psb_success_
name='psi_swap_datav' name='psi_swap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -1393,6 +1394,7 @@ subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_penv_mod use psb_penv_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -1447,7 +1449,7 @@ subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data)
call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list')
goto 9999 goto 9999
end if end if
if (.false.) then if (.not.(if_caf2)) then
call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info)
else else
call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info) call psi_swaptran(ictxt,icomm,flag,beta,y,d_xchg,info)

2
base/internals/Makefile
Unescape Escape View File

@ -37,7 +37,7 @@ lib: mpfobjs $(FOBJS) $(FOBJS2) $(COBJS) $(MPFOBJS2) $(MPFOBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME) $(RANLIB) $(LIBDIR)/$(LIBNAME)
$(FOBJS) $(FBOJS2): $(MODDIR)/psi_mod.o $(FOBJS) $(FBOJS2): $(MODDIR)/psi_mod.o
mpfobjs: mpfobjs:
(make $(MPFOBJS) F90="$(MPF90)" FC="$(MPF90)" FCOPT="$(F90COPT)") (make $(MPFOBJS) F90="$(MPF90)" FC="$(MPF90)" FCOPT="$(F90COPT)")
(make $(FOBJS2) F90="$(MPF77)" FC="$(MPF77)" FCOPT="$(FCOPT)") (make $(FOBJS2) F90="$(MPF77)" FC="$(MPF77)" FCOPT="$(FCOPT)")
clean: clean:

36
base/internals/psb_indx_map_fnd_owner.F90
Unescape Escape View File

@ -1,4 +1,4 @@
!!$ !ii!$
!!$ Parallel Sparse BLAS version 3.4 !!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015 !!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata !!$ Salvatore Filippone University of Rome Tor Vergata
@ -51,6 +51,7 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
use psb_error_mod use psb_error_mod
use psb_penv_mod use psb_penv_mod
use psb_realloc_mod use psb_realloc_mod
use psb_caf_mod
use psb_indx_map_mod, psb_protect_name => psb_indx_map_fnd_owner use psb_indx_map_mod, psb_protect_name => psb_indx_map_fnd_owner
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -168,10 +169,13 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
if (gettime) then if (gettime) then
t3 = psb_wtime() t3 = psb_wtime()
end if end if
if (if_caf) then
call mpi_allgatherv(idx,hsz(me+1),psb_mpi_ipk_integer,& call caf_allgatherv(idx, hsz(me+1), hproc, hsz, hidx, info)
& hproc,hsz,hidx,psb_mpi_ipk_integer,& else
& icomm,minfo) call mpi_allgatherv(idx,hsz(me+1),psb_mpi_ipk_integer,&
& hproc,hsz,hidx,psb_mpi_ipk_integer,&
& icomm,minfo)
endif
if (gettime) then if (gettime) then
tamx = psb_wtime() - t3 tamx = psb_wtime() - t3
end if end if
@ -211,11 +215,15 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
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_def_integer,& if (if_caf) then
& rvsz,1,psb_mpi_def_integer,icomm,minfo) call caf_alltoall(sdsz,rvsz, 1, minfo)
else
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,&
& rvsz,1,psb_mpi_def_integer,icomm,minfo)
endif
isz = sum(rvsz) isz = sum(rvsz)
allocate(answers(isz,2),idxsrch(nv,2),stat=info) allocate(answers(isz,2),idxsrch(nv,2),stat=info)
@ -228,9 +236,15 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info)
rvidx(ip) = j rvidx(ip) = j
j = j + rvsz(ip) j = j + rvsz(ip)
end do end do
call mpi_alltoallv(hproc,sdsz,sdidx,psb_mpi_ipk_integer,& print*,'---------hproc', hproc,'sdsz',sdsz,'sdidx',sdidx,'answers',answers(:,1), 'rvsz', rvsz,'rvidx', rvidx, this_image()
& answers(:,1),rvsz,rvidx,psb_mpi_ipk_integer,&
& icomm,minfo) if (if_caf) then
call caf_alltoallv(hproc, sdsz,sdidx, answers(:,1),rvsz,rvidx, minfo)
else
call mpi_alltoallv(hproc,sdsz,sdidx,psb_mpi_ipk_integer,&
& answers(:,1),rvsz,rvidx,psb_mpi_ipk_integer,&
& icomm,minfo)
endif
if (gettime) then if (gettime) then
tamx = psb_wtime() - t3 + tamx tamx = psb_wtime() - t3 + tamx
end if end if

42
base/internals/psi_desc_impl.f90
Unescape Escape View File

@ -63,20 +63,23 @@ end subroutine psi_renum_index
subroutine psi_cnv_v2xch(ictxt, vidx_in, xch_idx,info) subroutine psi_cnv_v2xch(ictxt, vidx_in, xch_idx,info)
use psi_mod, psi_protect_name => psi_cnv_v2xch use psi_mod, psi_protect_name => psi_cnv_v2xch
use psb_realloc_mod use psb_realloc_mod
use psb_caf_mod
implicit none implicit none
integer(psb_ipk_), intent(in) :: ictxt, vidx_in(:) integer(psb_ipk_), intent(in) :: ictxt, vidx_in(:)
type(psb_xch_idx_type), intent(inout) :: xch_idx type(psb_xch_idx_type), intent(inout) :: xch_idx
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! ....local scalars.... ! ....local scalars....
integer(psb_ipk_) :: np, me integer(psb_ipk_) :: np, me, img
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: nxch, nsnd, nrcv, nesd,nerv, ip, j, k, ixch integer(psb_ipk_) :: nxch, nsnd, nrcv, nesd,nerv, ip, j, k, ixch
! ...parameters ! ...parameters
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
character(len=20) :: name character(len=20) :: name
integer(psb_ipk_), allocatable :: buf_rmt_rcv_bnd(:)[:], buf_rmt_snd_bnd(:)[:]
type(event_type), allocatable, save :: snd_done(:)[:]
type(event_type), save :: rcv_done[*]
name='psi_cnv_v2xch' name='psi_cnv_v2xch'
call psb_get_erraction(err_act) call psb_get_erraction(err_act)
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
@ -85,6 +88,8 @@ subroutine psi_cnv_v2xch(ictxt, vidx_in, xch_idx,info)
info = psb_success_ info = psb_success_
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
me = this_image()
np = num_images()
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)
@ -114,6 +119,12 @@ subroutine psi_cnv_v2xch(ictxt, vidx_in, xch_idx,info)
ixch = 1 ixch = 1
xch_idx%loc_snd_bnd(1) = 1 xch_idx%loc_snd_bnd(1) = 1
xch_idx%loc_rcv_bnd(1) = 1 xch_idx%loc_rcv_bnd(1) = 1
if (if_caf) then
if (allocated(buf_rmt_rcv_bnd)) deallocate(buf_rmt_rcv_bnd)
if (allocated(buf_rmt_snd_bnd)) deallocate(buf_rmt_snd_bnd)
if (allocated(snd_done)) deallocate(snd_done)
allocate(buf_rmt_rcv_bnd(np*2)[*], buf_rmt_snd_bnd(np*2)[*], snd_done(np)[*])
endif
do do
if (ip > size(vidx_in)) then if (ip > size(vidx_in)) then
write(psb_err_unit,*) trim(name),': Warning: out of size of input vector ' write(psb_err_unit,*) trim(name),': Warning: out of size of input vector '
@ -131,17 +142,32 @@ subroutine psi_cnv_v2xch(ictxt, vidx_in, xch_idx,info)
& vidx_in(ip+nerv+psb_n_elem_send_+1:ip+nerv+psb_n_elem_send_+nesd) & vidx_in(ip+nerv+psb_n_elem_send_+1:ip+nerv+psb_n_elem_send_+nesd)
xch_idx%loc_rcv_bnd(ixch+1) = xch_idx%loc_rcv_bnd(ixch) + nerv xch_idx%loc_rcv_bnd(ixch+1) = xch_idx%loc_rcv_bnd(ixch) + nerv
xch_idx%loc_snd_bnd(ixch+1) = xch_idx%loc_snd_bnd(ixch) + nesd xch_idx%loc_snd_bnd(ixch+1) = xch_idx%loc_snd_bnd(ixch) + nesd
call psb_snd(ictxt,xch_idx%loc_rcv_bnd(ixch:ixch+1),xch_idx%prcs_xch(ixch)) img = xch_idx%prcs_xch(ixch) + 1
call psb_snd(ictxt,xch_idx%loc_snd_bnd(ixch:ixch+1),xch_idx%prcs_xch(ixch)) !Here I am assuming that all the data exchange between two images takes place in one exchange
call psb_rcv(ictxt,xch_idx%rmt_rcv_bnd(ixch,1:2),xch_idx%prcs_xch(ixch)) if (if_caf) then
call psb_rcv(ictxt,xch_idx%rmt_snd_bnd(ixch,1:2),xch_idx%prcs_xch(ixch)) buf_rmt_rcv_bnd(me*2 - 1 : me*2)[img]= xch_idx%loc_rcv_bnd(ixch:ixch+1)
buf_rmt_snd_bnd(me*2 - 1 : me*2)[img]= xch_idx%loc_snd_bnd(ixch:ixch+1)
event post(snd_done(me)[img])
event wait(snd_done(img))
xch_idx%rmt_rcv_bnd(ixch,1:2)=buf_rmt_rcv_bnd(img*2 - 1 : img*2)
xch_idx%rmt_snd_bnd(ixch,1:2)=buf_rmt_snd_bnd(img*2 - 1 : img*2)
else
call psb_snd(ictxt,xch_idx%loc_rcv_bnd(ixch:ixch+1),xch_idx%prcs_xch(ixch))
call psb_snd(ictxt,xch_idx%loc_snd_bnd(ixch:ixch+1),xch_idx%prcs_xch(ixch))
call psb_rcv(ictxt,xch_idx%rmt_rcv_bnd(ixch,1:2),xch_idx%prcs_xch(ixch))
call psb_rcv(ictxt,xch_idx%rmt_snd_bnd(ixch,1:2),xch_idx%prcs_xch(ixch))
endif
ip = ip+nerv+nesd+3 ip = ip+nerv+nesd+3
ixch = ixch + 1 ixch = ixch + 1
end do end do
xch_idx%rmt_rcv_bnd(:,2) = xch_idx%rmt_rcv_bnd(:,2) - 1 xch_idx%rmt_rcv_bnd(:,2) = xch_idx%rmt_rcv_bnd(:,2) - 1
xch_idx%rmt_snd_bnd(:,2) = xch_idx%rmt_snd_bnd(:,2) - 1 xch_idx%rmt_snd_bnd(:,2) = xch_idx%rmt_snd_bnd(:,2) - 1
if (if_caf) then
if (allocated(buf_rmt_rcv_bnd)) deallocate(buf_rmt_rcv_bnd)
if (allocated(buf_rmt_snd_bnd)) deallocate(buf_rmt_snd_bnd)
if (allocated(snd_done)) deallocate(snd_done)
sync all
endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

21
base/internals/psi_desc_index.F90
Unescape Escape View File

@ -98,8 +98,11 @@
! is rebuilt during the CDASB process (in the psi_ldsc_pre_halo subroutine). ! is rebuilt during the CDASB process (in the psi_ldsc_pre_halo subroutine).
! !
! !
subroutine psi_desc_index(desc,index_in,dep_list,& subroutine psi_desc_index(desc,index_in,dep_list,&
& length_dl,nsnd,nrcv,desc_index,isglob_in,info) & length_dl,nsnd,nrcv,desc_index,isglob_in,info)
use psb_caf_mod
use psb_desc_mod use psb_desc_mod
use psb_realloc_mod use psb_realloc_mod
use psb_error_mod use psb_error_mod
@ -165,6 +168,7 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
! to be received/sent (in the final psblas descriptor). ! to be received/sent (in the final psblas descriptor).
! be careful of the inversion ! be careful of the inversion
! !
allocate(sdsz(np),rvsz(np),bsdindx(np),brvindx(np),stat=info) allocate(sdsz(np),rvsz(np),bsdindx(np),brvindx(np),stat=info)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_alloc_dealloc_ info=psb_err_alloc_dealloc_
@ -186,7 +190,14 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
i = i + nerv + 1 i = i + nerv + 1
end do end do
ihinsz=i ihinsz=i
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1,psb_mpi_def_integer,icomm,minfo) !call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1,psb_mpi_def_integer,icomm,minfo)
if (if_caf) then
call caf_alltoall(sdsz, rvsz,1, minfo)
else
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1,psb_mpi_def_integer,icomm,minfo)
endif
if (minfo /= psb_success_) then if (minfo /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoall') call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoall')
goto 9999 goto 9999
@ -291,9 +302,13 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
brvindx(proc+1) = idxr brvindx(proc+1) = idxr
idxr = idxr + rvsz(proc+1) idxr = idxr + rvsz(proc+1)
end do end do
if (if_caf) then
call caf_alltoallv(sndbuf, sdsz, bsdindx, rcvbuf, rvsz, brvindx, minfo)
else
call mpi_alltoallv(sndbuf,sdsz,bsdindx,psb_mpi_ipk_integer,&
& rcvbuf,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo)
call mpi_alltoallv(sndbuf,sdsz,bsdindx,psb_mpi_ipk_integer,& endif
& rcvbuf,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo)
if (minfo /= psb_success_) then if (minfo /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoallv') call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoallv')
goto 9999 goto 9999

10
base/internals/psi_extrct_dl.F90
Unescape Escape View File

@ -126,6 +126,7 @@ subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,&
use psb_const_mod use psb_const_mod
use psb_error_mod use psb_error_mod
use psb_desc_mod use psb_desc_mod
use psb_caf_mod
implicit none implicit none
#ifdef MPI_H #ifdef MPI_H
include 'mpif.h' include 'mpif.h'
@ -272,8 +273,13 @@ subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,&
endif endif
itmp(1:dl_lda) = dep_list(1:dl_lda,me) itmp(1:dl_lda) = dep_list(1:dl_lda,me)
dl_mpi = dl_lda dl_mpi = dl_lda
call mpi_allgather(itmp,dl_mpi,psb_mpi_ipk_integer,&
& dep_list,dl_mpi,psb_mpi_ipk_integer,icomm,minfo) if (if_caf) then
call caf_allgather(itmp,dl_mpi, dep_list, minfo)
else
call mpi_allgather(itmp,dl_mpi,psb_mpi_ipk_integer,&
& dep_list,dl_mpi,psb_mpi_ipk_integer,icomm,minfo)
endif
info = minfo info = minfo
if (info == 0) deallocate(itmp,stat=info) if (info == 0) deallocate(itmp,stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then

11
base/modules/Makefile
Unescape Escape View File

@ -1,6 +1,6 @@
include ../../Make.inc include ../../Make.inc
BASIC_MODS= psb_const_mod.o psb_error_mod.o psb_realloc_mod.o BASIC_MODS= psb_const_mod.o psb_error_mod.o psb_realloc_mod.o psb_caf_mod.o
COMMINT=psi_comm_buffers_mod.o psi_penv_mod.o psi_bcast_mod.o psi_reduce_mod.o psi_p2p_mod.o COMMINT=psi_comm_buffers_mod.o psi_penv_mod.o psi_bcast_mod.o psi_reduce_mod.o psi_p2p_mod.o
UTIL_MODS = aux/psb_string_mod.o desc/psb_desc_const_mod.o desc/psb_indx_map_mod.o\ UTIL_MODS = aux/psb_string_mod.o desc/psb_desc_const_mod.o desc/psb_indx_map_mod.o\
desc/psb_gen_block_map_mod.o desc/psb_list_map_mod.o desc/psb_repl_map_mod.o\ desc/psb_gen_block_map_mod.o desc/psb_list_map_mod.o desc/psb_repl_map_mod.o\
@ -36,9 +36,8 @@ UTIL_MODS = aux/psb_string_mod.o desc/psb_desc_const_mod.o desc/psb_indx_map_mod
serial/psb_c_base_mat_mod.o serial/psb_c_csr_mat_mod.o serial/psb_c_csc_mat_mod.o serial/psb_c_mat_mod.o \ serial/psb_c_base_mat_mod.o serial/psb_c_csr_mat_mod.o serial/psb_c_csc_mat_mod.o serial/psb_c_mat_mod.o \
serial/psb_z_base_mat_mod.o serial/psb_z_csr_mat_mod.o serial/psb_z_csc_mat_mod.o serial/psb_z_mat_mod.o serial/psb_z_base_mat_mod.o serial/psb_z_csr_mat_mod.o serial/psb_z_csc_mat_mod.o serial/psb_z_mat_mod.o
MODULES=$(BASIC_MODS) $(UTIL_MODS) MODULES=$(BASIC_MODS) $(UTIL_MODS)
OBJS = error.o psb_base_mod.o $(EXTRA_COBJS) cutil.o OBJS = error.o psb_base_mod.o $(EXTRA_COBJS) cutil.o
LIBDIR=.. LIBDIR=..
CINCLUDES=-I. CINCLUDES=-I.
FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG). $(FIFLAG). FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG). $(FIFLAG).
@ -57,7 +56,7 @@ psb_realloc_mod.o: psb_error_mod.o
$(UTIL_MODS): $(BASIC_MODS) $(UTIL_MODS): $(BASIC_MODS)
psi_penv_mod.o: psi_comm_buffers_mod.o psi_penv_mod.o: psi_comm_buffers_mod.o
psi_bcast_mod.o psi_reduce_mod.o psi_p2p_mod.o: psi_penv_mod.o psi_bcast_mod.o psi_reduce_mod.o psi_p2p_mod.o: psi_penv_mod.o psb_caf_mod.o
aux/psb_string_mod.o desc/psb_desc_const_mod.o psi_comm_buffers_mod.o: psb_const_mod.o aux/psb_string_mod.o desc/psb_desc_const_mod.o psi_comm_buffers_mod.o: psb_const_mod.o
@ -155,6 +154,10 @@ psblas/psb_s_psblas_mod.o psblas/psb_c_psblas_mod.o psblas/psb_d_psblas_mod.o ps
psb_base_mod.o: $(MODULES) psb_base_mod.o: $(MODULES)
psb_caf_mod.o: psb_caf_mod.f90 psb_const_mod.o
$(F90) $(FINCLUDES) $(FDEFINES) $(F90COPT) $(EXTRA_OPT) -c $< -o $@
psi_penv_mod.o: psi_penv_mod.F90 $(BASIC_MODS) psi_penv_mod.o: psi_penv_mod.F90 $(BASIC_MODS)
$(F90) $(FINCLUDES) $(FDEFINES) $(F90COPT) $(EXTRA_OPT) -c $< -o $@ $(F90) $(FINCLUDES) $(FDEFINES) $(F90COPT) $(EXTRA_OPT) -c $< -o $@

2
base/modules/desc/psb_desc_mod.F90
Unescape Escape View File

@ -707,7 +707,7 @@ contains
do do
if (ip > size(idx)) then if (ip > size(idx)) then
write(psb_err_unit,*) trim(name),': Warning: out of size of input vector ' write(psb_err_unit,*) trim(name),': Warning: out of size of input vector ', this_image(),ip, size(idx)
exit exit
end if end if
if (idx(ip) == -1) exit if (idx(ip) == -1) exit

324
base/modules/psi_bcast_mod.F90
Unescape Escape View File

@ -70,6 +70,7 @@ contains
subroutine psb_ibcasts(ictxt,dat,root) subroutine psb_ibcasts(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -79,8 +80,8 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
integer(psb_ipk_), intent(inout) :: dat integer(psb_ipk_), intent(inout) :: dat
integer(psb_ipk_), allocatable :: dat_buf[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
@ -90,12 +91,22 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,1,psb_mpi_ipk_integer,root_,ictxt,info) if (allocated(dat_buf)) deallocate(dat_buf)
allocate(dat_buf[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,1,psb_mpi_ipk_integer,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_ibcasts end subroutine psb_ibcasts
subroutine psb_ibcastv(ictxt,dat,root) subroutine psb_ibcastv(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -105,6 +116,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
integer(psb_ipk_), intent(inout) :: dat(:) integer(psb_ipk_), intent(inout) :: dat(:)
integer(psb_ipk_), allocatable :: dat_buf(:)[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
@ -114,13 +126,23 @@ contains
else else
root_ = psb_root_ root_ = psb_root_
endif endif
if (if_caf2) then
call psb_info(ictxt,iam,np) if (allocated(dat_buf)) deallocate(dat_buf)
call mpi_bcast(dat,size(dat),psb_mpi_ipk_integer,root_,ictxt,info) allocate(dat_buf(size(dat))[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
if (allocated(dat_buf)) deallocate(dat_buf)
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,size(dat),psb_mpi_ipk_integer,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_ibcastv end subroutine psb_ibcastv
subroutine psb_ibcastm(ictxt,dat,root) subroutine psb_ibcastm(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -130,6 +152,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
integer(psb_ipk_), intent(inout) :: dat(:,:) integer(psb_ipk_), intent(inout) :: dat(:,:)
integer(psb_ipk_), allocatable :: dat_buf(:,:)[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
@ -140,14 +163,24 @@ contains
else else
root_ = psb_root_ root_ = psb_root_
endif endif
if (if_caf2) then
call psb_info(ictxt,iam,np) if (allocated(dat_buf)) deallocate(dat_buf)
call mpi_bcast(dat,size(dat),psb_mpi_ipk_integer,root_,ictxt,info) allocate(dat_buf(size(dat,1),size(dat,2))[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
if (allocated(dat_buf)) deallocate(dat_buf)
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,size(dat),psb_mpi_ipk_integer,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_ibcastm end subroutine psb_ibcastm
subroutine psb_sbcasts(ictxt,dat,root) subroutine psb_sbcasts(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -157,6 +190,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
real(psb_spk_), intent(inout) :: dat real(psb_spk_), intent(inout) :: dat
real(psb_spk_), allocatable :: dat_buf[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
@ -168,13 +202,23 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,1,psb_mpi_r_spk_,root_,ictxt,info) if (allocated(dat_buf)) deallocate(dat_buf)
allocate(dat_buf[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,1,psb_mpi_r_spk_,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_sbcasts end subroutine psb_sbcasts
subroutine psb_sbcastv(ictxt,dat,root) subroutine psb_sbcastv(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -184,6 +228,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
real(psb_spk_), intent(inout) :: dat(:) real(psb_spk_), intent(inout) :: dat(:)
real(psb_spk_), allocatable :: dat_buf(:)[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
@ -195,13 +240,23 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,size(dat),psb_mpi_r_spk_,root_,ictxt,info) if (allocated(dat_buf)) deallocate(dat_buf)
allocate(dat_buf(size(dat))[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
if (allocated(dat_buf)) deallocate(dat_buf)
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,size(dat),psb_mpi_r_spk_,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_sbcastv end subroutine psb_sbcastv
subroutine psb_sbcastm(ictxt,dat,root) subroutine psb_sbcastm(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -211,6 +266,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
real(psb_spk_), intent(inout) :: dat(:,:) real(psb_spk_), intent(inout) :: dat(:,:)
real(psb_spk_), allocatable :: dat_buf(:,:)[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
@ -222,14 +278,24 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,size(dat),psb_mpi_r_spk_,root_,ictxt,info) if (allocated(dat_buf)) deallocate(dat_buf)
allocate(dat_buf(size(dat,1),size(dat,2))[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
if (allocated(dat_buf)) deallocate(dat_buf)
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,size(dat),psb_mpi_r_spk_,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_sbcastm end subroutine psb_sbcastm
subroutine psb_dbcasts(ictxt,dat,root) subroutine psb_dbcasts(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -239,6 +305,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
real(psb_dpk_), intent(inout) :: dat real(psb_dpk_), intent(inout) :: dat
real(psb_dpk_), allocatable :: dat_buf[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
@ -250,13 +317,23 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,1,psb_mpi_r_dpk_,root_,ictxt,info) if (allocated(dat_buf)) deallocate(dat_buf)
allocate(dat_buf[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,1,psb_mpi_r_dpk_,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_dbcasts end subroutine psb_dbcasts
subroutine psb_dbcastv(ictxt,dat,root) subroutine psb_dbcastv(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -266,6 +343,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
real(psb_dpk_), intent(inout) :: dat(:) real(psb_dpk_), intent(inout) :: dat(:)
real(psb_dpk_), allocatable :: dat_buf(:)[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
@ -277,12 +355,23 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,size(dat),psb_mpi_r_dpk_,root_,ictxt,info) if (allocated(dat_buf)) deallocate(dat_buf)
allocate(dat_buf(size(dat))[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
if (allocated(dat_buf)) deallocate(dat_buf)
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,size(dat),psb_mpi_r_dpk_,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_dbcastv end subroutine psb_dbcastv
subroutine psb_dbcastm(ictxt,dat,root) subroutine psb_dbcastm(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -292,6 +381,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
real(psb_dpk_), intent(inout) :: dat(:,:) real(psb_dpk_), intent(inout) :: dat(:,:)
real(psb_dpk_), allocatable :: dat_buf(:,:)[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
@ -303,12 +393,23 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,size(dat),psb_mpi_r_dpk_,root_,ictxt,info) if (allocated(dat_buf)) deallocate(dat_buf)
allocate(dat_buf(size(dat,1),size(dat,2))[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
if (allocated(dat_buf)) deallocate(dat_buf)
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,size(dat),psb_mpi_r_dpk_,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_dbcastm end subroutine psb_dbcastm
subroutine psb_cbcasts(ictxt,dat,root) subroutine psb_cbcasts(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -318,10 +419,10 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
complex(psb_spk_), intent(inout) :: dat complex(psb_spk_), intent(inout) :: dat
complex(psb_spk_), allocatable :: dat_buf[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
#if !defined(SERIAL_MPI) #if !defined(SERIAL_MPI)
if (present(root)) then if (present(root)) then
root_ = root root_ = root
@ -329,12 +430,22 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,1,psb_mpi_c_spk_,root_,ictxt,info) if (allocated(dat_buf)) deallocate(dat_buf)
allocate(dat_buf[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,1,psb_mpi_r_dpk_,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_cbcasts end subroutine psb_cbcasts
subroutine psb_cbcastv(ictxt,dat,root) subroutine psb_cbcastv(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -344,6 +455,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
complex(psb_spk_), intent(inout) :: dat(:) complex(psb_spk_), intent(inout) :: dat(:)
complex(psb_spk_), allocatable :: dat_buf(:)[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
@ -355,12 +467,23 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,size(dat),psb_mpi_c_spk_,root_,ictxt,info) if (allocated(dat_buf)) deallocate(dat_buf)
allocate(dat_buf(size(dat))[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
if (allocated(dat_buf)) deallocate(dat_buf)
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,size(dat),psb_mpi_c_spk_,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_cbcastv end subroutine psb_cbcastv
subroutine psb_cbcastm(ictxt,dat,root) subroutine psb_cbcastm(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -370,6 +493,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
complex(psb_spk_), intent(inout) :: dat(:,:) complex(psb_spk_), intent(inout) :: dat(:,:)
complex(psb_spk_), allocatable :: dat_buf(:,:)[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
@ -381,12 +505,23 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,size(dat),psb_mpi_c_spk_,root_,ictxt,info) if (allocated(dat_buf)) deallocate(dat_buf)
allocate(dat_buf(size(dat,1),size(dat,2))[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
if (allocated(dat_buf)) deallocate(dat_buf)
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,size(dat),psb_mpi_c_spk_,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_cbcastm end subroutine psb_cbcastm
subroutine psb_zbcasts(ictxt,dat,root) subroutine psb_zbcasts(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -396,6 +531,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
complex(psb_dpk_), intent(inout) :: dat complex(psb_dpk_), intent(inout) :: dat
complex(psb_dpk_), allocatable :: dat_buf[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
@ -407,12 +543,25 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,1,psb_mpi_c_dpk_,root_,ictxt,info)
if (allocated(dat_buf)) deallocate(dat_buf)
allocate(dat_buf[*])
dat_buf=dat
sync all
!print*,'****',this_image(), dat_buf, dat
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
!print*,'***** after',this_image(), dat
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,1,psb_mpi_c_dpk_,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_zbcasts end subroutine psb_zbcasts
subroutine psb_zbcastv(ictxt,dat,root) subroutine psb_zbcastv(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -422,6 +571,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
complex(psb_dpk_), intent(inout) :: dat(:) complex(psb_dpk_), intent(inout) :: dat(:)
complex(psb_dpk_), allocatable :: dat_buf(:)[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
@ -433,12 +583,23 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,size(dat),psb_mpi_c_dpk_,root_,ictxt,info) if (allocated(dat_buf)) deallocate(dat_buf)
allocate(dat_buf(size(dat))[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
if (allocated(dat_buf)) deallocate(dat_buf)
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,size(dat),psb_mpi_c_dpk_,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_zbcastv end subroutine psb_zbcastv
subroutine psb_zbcastm(ictxt,dat,root) subroutine psb_zbcastm(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -448,6 +609,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
complex(psb_dpk_), intent(inout) :: dat(:,:) complex(psb_dpk_), intent(inout) :: dat(:,:)
complex(psb_dpk_), allocatable :: dat_buf(:,:)[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
@ -459,13 +621,24 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,size(dat),psb_mpi_c_dpk_,root_,ictxt,info) if (allocated(dat_buf)) deallocate(dat_buf)
allocate(dat_buf(size(dat,1),size(dat,2))[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
if (allocated(dat_buf)) deallocate(dat_buf)
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,size(dat),psb_mpi_c_dpk_,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_zbcastm end subroutine psb_zbcastm
subroutine psb_hbcasts(ictxt,dat,root,length) subroutine psb_hbcasts(ictxt,dat,root,length)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -492,13 +665,13 @@ contains
endif endif
call psb_info(ictxt,iam,np) call psb_info(ictxt,iam,np)
call mpi_bcast(dat,length_,MPI_CHARACTER,root_,ictxt,info) call mpi_bcast(dat,length_,MPI_CHARACTER,root_,ictxt,info)
#endif #endif
end subroutine psb_hbcasts end subroutine psb_hbcasts
subroutine psb_hbcastv(ictxt,dat,root) subroutine psb_hbcastv(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -522,13 +695,13 @@ contains
size_ = size(dat) size_ = size(dat)
call psb_info(ictxt,iam,np) call psb_info(ictxt,iam,np)
call mpi_bcast(dat,length_*size_,MPI_CHARACTER,root_,ictxt,info) call mpi_bcast(dat,length_*size_,MPI_CHARACTER,root_,ictxt,info)
#endif #endif
end subroutine psb_hbcastv end subroutine psb_hbcastv
subroutine psb_lbcasts(ictxt,dat,root) subroutine psb_lbcasts(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -538,6 +711,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
logical, intent(inout) :: dat logical, intent(inout) :: dat
logical, allocatable :: dat_buf[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_,info integer(psb_mpik_) :: iam, np, root_,info
@ -549,14 +723,24 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,1,MPI_LOGICAL,root_,ictxt,info) if (allocated(dat_buf)) deallocate(dat_buf)
allocate(dat_buf[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,1,MPI_LOGICAL,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_lbcasts end subroutine psb_lbcasts
subroutine psb_lbcastv(ictxt,dat,root) subroutine psb_lbcastv(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -566,6 +750,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
logical, intent(inout) :: dat(:) logical, intent(inout) :: dat(:)
logical, allocatable :: dat_buf(:)[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_,info integer(psb_mpik_) :: iam, np, root_,info
@ -577,16 +762,25 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,size(dat),MPI_LOGICAL,root_,ictxt,info) allocate(dat_buf(size(dat))[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
if (allocated(dat_buf)) deallocate(dat_buf)
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,size(dat),MPI_LOGICAL,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_lbcastv end subroutine psb_lbcastv
#if !defined(LONG_INTEGERS) #if !defined(LONG_INTEGERS)
subroutine psb_i8bcasts(ictxt,dat,root) subroutine psb_i8bcasts(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -596,6 +790,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
integer(psb_long_int_k_), intent(inout) :: dat integer(psb_long_int_k_), intent(inout) :: dat
integer(psb_long_int_k_), allocatable :: dat_buf[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
@ -607,12 +802,22 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,1,psb_mpi_lng_integer,root_,ictxt,info) if (allocated(dat_buf)) deallocate(dat_buf)
allocate(dat_buf[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,1,psb_mpi_lng_integer,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_i8bcasts end subroutine psb_i8bcasts
subroutine psb_i8bcastv(ictxt,dat,root) subroutine psb_i8bcastv(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -622,6 +827,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
integer(psb_long_int_k_), intent(inout) :: dat(:) integer(psb_long_int_k_), intent(inout) :: dat(:)
integer(psb_long_int_k_), allocatable :: dat_buf(:)[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
@ -632,12 +838,22 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,size(dat),psb_mpi_lng_integer,root_,ictxt,info) allocate(dat_buf(size(dat))[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
if (allocated(dat_buf)) deallocate(dat_buf)
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,size(dat),psb_mpi_lng_integer,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_i8bcastv end subroutine psb_i8bcastv
subroutine psb_i8bcastm(ictxt,dat,root) subroutine psb_i8bcastm(ictxt,dat,root)
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -647,6 +863,7 @@ contains
#endif #endif
integer(psb_mpik_), intent(in) :: ictxt integer(psb_mpik_), intent(in) :: ictxt
integer(psb_long_int_k_), intent(inout) :: dat(:,:) integer(psb_long_int_k_), intent(inout) :: dat(:,:)
integer(psb_long_int_k_), allocatable :: dat_buf(:,:)[:]
integer(psb_mpik_), intent(in), optional :: root integer(psb_mpik_), intent(in), optional :: root
integer(psb_mpik_) :: iam, np, root_, info integer(psb_mpik_) :: iam, np, root_, info
@ -658,8 +875,17 @@ contains
root_ = psb_root_ root_ = psb_root_
endif endif
call psb_info(ictxt,iam,np) if (if_caf2) then
call mpi_bcast(dat,size(dat),psb_mpi_lng_integer,root_,ictxt,info) allocate(dat_buf(size(dat,1),size(dat,2))[*])
dat_buf=dat
sync all
call co_broadcast(dat_buf,root_ + 1)
dat = dat_buf
if (allocated(dat_buf)) deallocate(dat_buf)
else
call psb_info(ictxt,iam,np)
call mpi_bcast(dat,size(dat),psb_mpi_lng_integer,root_,ictxt,info)
endif
#endif #endif
end subroutine psb_i8bcastm end subroutine psb_i8bcastm

48
base/modules/psi_i_mod.f90
Unescape Escape View File

@ -244,6 +244,14 @@ module psi_i_mod
type(psb_desc_type), target :: desc_a type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data integer(psb_ipk_), optional :: data
end subroutine psi_iswapdata_multivect end subroutine psi_iswapdata_multivect
subroutine psi_iswap_xchg_m(iictxt,iicomm,flag,m,beta,y,xchg,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,m
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: y(:,:)
integer(psb_ipk_) :: beta
class(psb_xch_idx_type), intent(inout) :: xchg
end subroutine psi_iswap_xchg_m
subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,& subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
import import
@ -253,6 +261,14 @@ module psi_i_mod
integer(psb_ipk_),target :: work(:) integer(psb_ipk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_iswapidxm end subroutine psi_iswapidxm
subroutine psi_iswap_xchg_v(iictxt,iicomm,flag,beta,y,xchg,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: y(:)
integer(psb_ipk_) :: beta
class(psb_xch_idx_type), intent(inout) :: xchg
end subroutine psi_iswap_xchg_v
subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,& subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
import import
@ -262,6 +278,14 @@ module psi_i_mod
integer(psb_ipk_),target :: work(:) integer(psb_ipk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_iswapidxv end subroutine psi_iswapidxv
subroutine psi_iswap_xchg_vect(iictxt,iicomm,flag,beta,y,xchg,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
class(psb_xch_idx_type), intent(inout) :: xchg
end subroutine psi_iswap_xchg_vect
subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
import import
@ -326,6 +350,14 @@ module psi_i_mod
type(psb_desc_type), target :: desc_a type(psb_desc_type), target :: desc_a
integer(psb_ipk_), optional :: data integer(psb_ipk_), optional :: data
end subroutine psi_iswaptran_multivect end subroutine psi_iswaptran_multivect
subroutine psi_iswaptran_xchg_m(iictxt,iicomm,flag,m,beta,y,xchg,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,m
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: y(:,:)
integer(psb_ipk_) :: beta
class(psb_xch_idx_type), intent(inout) :: xchg
end subroutine psi_iswaptran_xchg_m
subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,& subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
import import
@ -335,6 +367,14 @@ module psi_i_mod
integer(psb_ipk_),target :: work(:) integer(psb_ipk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_itranidxm end subroutine psi_itranidxm
subroutine psi_iswaptran_xchg_v(iictxt,iicomm,flag,beta,y,xchg,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: y(:)
integer(psb_ipk_) :: beta
class(psb_xch_idx_type), intent(inout) :: xchg
end subroutine psi_iswaptran_xchg_v
subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,& subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
import import
@ -344,6 +384,14 @@ module psi_i_mod
integer(psb_ipk_),target :: work(:) integer(psb_ipk_),target :: work(:)
integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv
end subroutine psi_itranidxv end subroutine psi_itranidxv
subroutine psi_iswaptran_xchg_vect(iictxt,iicomm,flag,beta,y,xchg,info)
import
integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag
integer(psb_ipk_), intent(out) :: info
class(psb_i_base_vect_type) :: y
integer(psb_ipk_) :: beta
class(psb_xch_idx_type), intent(inout) :: xchg
end subroutine psi_iswaptran_xchg_vect
subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,&
& totxch,totsnd,totrcv,work,info) & totxch,totsnd,totrcv,work,info)
import import

4168
base/modules/psi_reduce_mod.F90
View File

File diff suppressed because it is too large Load Diff

12
base/tools/psb_ccdbldext.F90
Unescape Escape View File

@ -63,7 +63,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
use psb_base_mod, psb_protect_name => psb_ccdbldext use psb_base_mod, psb_protect_name => psb_ccdbldext
use psi_mod use psi_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -467,9 +467,13 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
! Exchange data requests with everybody else: so far we have ! Exchange data requests with everybody else: so far we have
! accumulated RECV requests, we have an all-to-all to build ! accumulated RECV requests, we have an all-to-all to build
! matchings SENDs. ! matchings SENDs.
! !
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1, & if (if_caf) then
& psb_mpi_def_integer,icomm,minfo) call caf_alltoall(sdsz,rvsz,1, minfo)
else
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1, &
& psb_mpi_def_integer,icomm,minfo)
endif
if (minfo /= psb_success_) then if (minfo /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='mpi_alltoall') call psb_errpush(info,name,a_err='mpi_alltoall')

3
base/tools/psb_cdalv.f90
Unescape Escape View File

@ -1,4 +1,5 @@
!!$ !se/tools/psb_zallc.f90
!$
!!$ Parallel Sparse BLAS version 3.4 !!$ Parallel Sparse BLAS version 3.4
!!$ (C) Copyright 2006, 2010, 2015 !!$ (C) Copyright 2006, 2010, 2015
!!$ Salvatore Filippone University of Rome Tor Vergata !!$ Salvatore Filippone University of Rome Tor Vergata

10
base/tools/psb_csphalo.F90
Unescape Escape View File

@ -58,7 +58,7 @@
Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,&
& rowscale,colscale,outfmt,data) & rowscale,colscale,outfmt,data)
use psb_base_mod, psb_protect_name => psb_csphalo use psb_base_mod, psb_protect_name => psb_csphalo
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -195,8 +195,12 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,&
counter = counter+n_el_send+3 counter = counter+n_el_send+3
Enddo Enddo
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,& if (if_caf) then
& rvsz,1,psb_mpi_def_integer,icomm,minfo) call caf_alltoall(sdsz,rvsz,1, minfo)
else
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,&
& rvsz,1,psb_mpi_def_integer,icomm,minfo)
endif
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mpi_alltoall' ch_err='mpi_alltoall'

18
base/tools/psb_dcdbldext.F90
Unescape Escape View File

@ -63,6 +63,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
use psb_base_mod, psb_protect_name => psb_dcdbldext use psb_base_mod, psb_protect_name => psb_dcdbldext
use psi_mod use psi_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -468,8 +469,12 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
! accumulated RECV requests, we have an all-to-all to build ! accumulated RECV requests, we have an all-to-all to build
! matchings SENDs. ! matchings SENDs.
! !
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1, & if (if_caf) then
& psb_mpi_def_integer,icomm,minfo) call caf_alltoall(sdsz,rvsz,1, minfo)
else
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1, &
& psb_mpi_def_integer,icomm,minfo)
endif
if (minfo /= psb_success_) then if (minfo /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='mpi_alltoall') call psb_errpush(info,name,a_err='mpi_alltoall')
@ -503,9 +508,12 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
end if end if
lworkr = max(iszr,1) lworkr = max(iszr,1)
end if end if
if (if_caf) then
call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_ipk_integer,& call caf_alltoallv(works,sdsz,bsdindx, workr,rvsz,brvindx, minfo)
& workr,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) else
call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_ipk_integer,&
& workr,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo)
endif
if (minfo /= psb_success_) then if (minfo /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='mpi_alltoallv') call psb_errpush(info,name,a_err='mpi_alltoallv')

32
base/tools/psb_dsphalo.F90
Unescape Escape View File

@ -58,7 +58,7 @@
Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
& rowscale,colscale,outfmt,data) & rowscale,colscale,outfmt,data)
use psb_base_mod, psb_protect_name => psb_dsphalo use psb_base_mod, psb_protect_name => psb_dsphalo
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -195,8 +195,12 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
counter = counter+n_el_send+3 counter = counter+n_el_send+3
Enddo Enddo
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,& if (if_caf) then
& rvsz,1,psb_mpi_def_integer,icomm,minfo) call caf_alltoall(sdsz,rvsz,1, minfo)
else
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,&
& rvsz,1,psb_mpi_def_integer,icomm,minfo)
endif
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mpi_alltoall' ch_err='mpi_alltoall'
@ -278,13 +282,21 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
goto 9999 goto 9999
end if end if
if (if_caf) then
call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,& call caf_alltoallv(valsnd,sdsz,bsdindx, acoo%val, rvsz,&
& acoo%val,rvsz,brvindx,psb_mpi_r_dpk_,icomm,minfo) & brvindx, minfo)
call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_ipk_integer,& call caf_alltoallv(iasnd,sdsz,bsdindx, acoo%ia, rvsz,&
& acoo%ia,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) & brvindx, minfo)
call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_ipk_integer,& call caf_alltoallv(jasnd,sdsz,bsdindx, acoo%ja, rvsz,&
& acoo%ja,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) & brvindx, minfo)
else
call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,&
& acoo%val,rvsz,brvindx,psb_mpi_r_dpk_,icomm,minfo)
call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_ipk_integer,&
& acoo%ia,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo)
call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_ipk_integer,&
& acoo%ja,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo)
endif
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mpi_alltoallv' ch_err='mpi_alltoallv'

11
base/tools/psb_scdbldext.F90
Unescape Escape View File

@ -63,6 +63,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
use psb_base_mod, psb_protect_name => psb_scdbldext use psb_base_mod, psb_protect_name => psb_scdbldext
use psi_mod use psi_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -467,9 +468,13 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
! Exchange data requests with everybody else: so far we have ! Exchange data requests with everybody else: so far we have
! accumulated RECV requests, we have an all-to-all to build ! accumulated RECV requests, we have an all-to-all to build
! matchings SENDs. ! matchings SENDs.
! !
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1, & if (if_caf) then
& psb_mpi_def_integer,icomm,minfo) call caf_alltoall(sdsz,rvsz,1,minfo)
else
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1, &
& psb_mpi_def_integer,icomm,minfo)
endif
if (minfo /= psb_success_) then if (minfo /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='mpi_alltoall') call psb_errpush(info,name,a_err='mpi_alltoall')

10
base/tools/psb_ssphalo.F90
Unescape Escape View File

@ -58,7 +58,7 @@
Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
& rowscale,colscale,outfmt,data) & rowscale,colscale,outfmt,data)
use psb_base_mod, psb_protect_name => psb_ssphalo use psb_base_mod, psb_protect_name => psb_ssphalo
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -195,8 +195,12 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
counter = counter+n_el_send+3 counter = counter+n_el_send+3
Enddo Enddo
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,& if (if_caf) then
& rvsz,1,psb_mpi_def_integer,icomm,minfo) call caf_alltoall(sdsz,rvsz,1, minfo)
else
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,&
& rvsz,1,psb_mpi_def_integer,icomm,minfo)
endif
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mpi_alltoall' ch_err='mpi_alltoall'

11
base/tools/psb_zcdbldext.F90
Unescape Escape View File

@ -63,6 +63,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
use psb_base_mod, psb_protect_name => psb_zcdbldext use psb_base_mod, psb_protect_name => psb_zcdbldext
use psi_mod use psi_mod
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
@ -467,9 +468,13 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
! Exchange data requests with everybody else: so far we have ! Exchange data requests with everybody else: so far we have
! accumulated RECV requests, we have an all-to-all to build ! accumulated RECV requests, we have an all-to-all to build
! matchings SENDs. ! matchings SENDs.
! !
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1, & if (if_caf) then
& psb_mpi_def_integer,icomm,minfo) call caf_alltoall(sdsz,rvsz,1, minfo)
else
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1, &
& psb_mpi_def_integer,icomm,minfo)
endif
if (minfo /= psb_success_) then if (minfo /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='mpi_alltoall') call psb_errpush(info,name,a_err='mpi_alltoall')

10
base/tools/psb_zsphalo.F90
Unescape Escape View File

@ -58,7 +58,7 @@
Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
& rowscale,colscale,outfmt,data) & rowscale,colscale,outfmt,data)
use psb_base_mod, psb_protect_name => psb_zsphalo use psb_base_mod, psb_protect_name => psb_zsphalo
use psb_caf_mod
#ifdef MPI_MOD #ifdef MPI_MOD
use mpi use mpi
#endif #endif
@ -195,8 +195,12 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
counter = counter+n_el_send+3 counter = counter+n_el_send+3
Enddo Enddo
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,& if (if_caf) then
& rvsz,1,psb_mpi_def_integer,icomm,minfo) call caf_alltoall(sdsz,rvsz,1, minfo)
else
call mpi_alltoall(sdsz,1,psb_mpi_def_integer,&
& rvsz,1,psb_mpi_def_integer,icomm,minfo)
endif
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='mpi_alltoall' ch_err='mpi_alltoall'

2
test/fileread/Makefile
Unescape Escape View File

@ -5,7 +5,7 @@ include $(INCDIR)/Make.inc.psblas
# Libraries used # Libraries used
# #
LIBDIR=$(BASEDIR)/lib/ LIBDIR=$(BASEDIR)/lib/
PSBLAS_LIB= -L$(LIBDIR) -lpsb_util -lpsb_krylov -lpsb_prec -lpsb_base PSBLAS_LIB= -L$(LIBDIR) -L/opencoarray-1.7.4 -lpsb_util -lpsb_krylov -lpsb_prec -lpsb_base -lcaf_mpi
LDLIBS=$(PSBLDLIBS) LDLIBS=$(PSBLDLIBS)
FINCLUDES=$(FMFLAG)$(INCDIR) $(FMFLAG). FINCLUDES=$(FMFLAG)$(INCDIR) $(FMFLAG).

4
test/fileread/runs/dfs.inp
Unescape Escape View File

@ -1,11 +1,11 @@
11 Number of inputs 11 Number of inputs
A_Z.mtx kivap005.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or bcsstk26.mtx kivap005.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or
NONE sherman3_b.mtx http://www.cise.ufl.edu/research/sparse/matrices/index.html NONE sherman3_b.mtx http://www.cise.ufl.edu/research/sparse/matrices/index.html
MM File format: MM: Matrix Market HB: Harwell-Boeing. MM File format: MM: Matrix Market HB: Harwell-Boeing.
CG BiCGSTAB Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL BICG CG CG BiCGSTAB Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL BICG CG
NONE BJAC Preconditioner NONE DIAG BJAC NONE BJAC Preconditioner NONE DIAG BJAC
CSR Storage format CSR COO JAD CSR Storage format CSR COO JAD
2 IPART: Partition method 0: BLK 2: graph (with Metis) 0 IPART: Partition method 0: BLK 2: graph (with Metis)
2 ISTOPC 2 ISTOPC
00100 ITMAX 00100 ITMAX
-1 ITRACE -1 ITRACE

4
test/integrationTest/Makefile
Unescape Escape View File

@ -3,7 +3,7 @@ INCDIR=$(BASEDIR)/include
include $(INCDIR)/Make.inc.psblas include $(INCDIR)/Make.inc.psblas
# #
# Libraries used # Libraries used
PFUNIT = /opt/pfunit/pfunit-coarrays-last PFUNIT = /opt/pfunit/pfunit-marzo2017
FFLAGS += -I$(INCDIR) -I$(PFUNIT)/mod -ISuites FFLAGS += -I$(INCDIR) -I$(PFUNIT)/mod -ISuites
LIBDIR=$(BASEDIR)/lib LIBDIR=$(BASEDIR)/lib
PSBLAS_LIB= -L/opencoarrays6.2 -L$(LIBDIR) -lcaf_mpi -lpsb_util -lpsb_base -llapack -lblas PSBLAS_LIB= -L/opencoarrays6.2 -L$(LIBDIR) -lcaf_mpi -lpsb_util -lpsb_base -llapack -lblas
@ -17,7 +17,7 @@ FINCLUDES=$(FMFLAG)$(INCDIR) $(FMFLAG).
all: prova all: prova
prova.x: test_psb_dmatdist.o test_psb_dhalo.o test_psb_shalo.o test_psb_chalo.o test_psb_zhalo.o test_psb_reduce_nrm2.o test_psb_sum.o test_psb_max.o test_psb_amx.o test_psb_min.o test_psb_amn.o test_psb_broadcast.o driver.o prova.x: test_psb_dmatdist.o test_psb_ihalo.o test_psb_dhalo.o test_psb_shalo.o test_psb_chalo.o test_psb_zhalo.o test_psb_reduce_nrm2.o test_psb_sum.o test_psb_max.o test_psb_amx.o test_psb_min.o test_psb_amn.o test_psb_broadcast.o test_psb_caf.o driver.o
$(FCFLAGS)$(F90LINK) -g $(LOPT) -o $@ $^ -L$(PFUNIT)/lib $(PSBLAS_LIB) $(LDLIBS) -DUSE_CAF -lpfunit -lmpi $(FCFLAGS)$(F90LINK) -g $(LOPT) -o $@ $^ -L$(PFUNIT)/lib $(PSBLAS_LIB) $(LDLIBS) -DUSE_CAF -lpfunit -lmpi
%: %.x %: %.x
mpirun -np 8 ./$^ mpirun -np 8 ./$^

2
test/integrationTest/Suites/testSuites.inc
Unescape Escape View File

@ -1,3 +1,4 @@
ADD_TEST_SUITE(test_psb_caf_suite)
ADD_TEST_SUITE(test_psb_reduce_nrm2_suite) ADD_TEST_SUITE(test_psb_reduce_nrm2_suite)
ADD_TEST_SUITE(test_psb_max_suite) ADD_TEST_SUITE(test_psb_max_suite)
ADD_TEST_SUITE(test_psb_amx_suite) ADD_TEST_SUITE(test_psb_amx_suite)
@ -5,6 +6,7 @@ ADD_TEST_SUITE(test_psb_min_suite)
ADD_TEST_SUITE(test_psb_amn_suite) ADD_TEST_SUITE(test_psb_amn_suite)
ADD_TEST_SUITE(test_psb_sum_suite) ADD_TEST_SUITE(test_psb_sum_suite)
ADD_TEST_SUITE(test_psb_broadcast_suite) ADD_TEST_SUITE(test_psb_broadcast_suite)
ADD_TEST_SUITE(test_psb_ihalo_suite)
ADD_TEST_SUITE(test_psb_dhalo_suite) ADD_TEST_SUITE(test_psb_dhalo_suite)
ADD_TEST_SUITE(test_psb_shalo_suite) ADD_TEST_SUITE(test_psb_shalo_suite)
ADD_TEST_SUITE(test_psb_chalo_suite) ADD_TEST_SUITE(test_psb_chalo_suite)

1
test/integrationTest/test_psb_broadcast.pf
Unescape Escape View File

@ -347,7 +347,6 @@ subroutine test_psb_dbroadcast_s(this)
double precision :: dat, check double precision :: dat, check
integer :: root, info, np, icontxt integer :: root, info, np, icontxt
call prepare_test(dat,check,root,info, np, icontxt) call prepare_test(dat,check,root,info, np, icontxt)
print*,'from test:', this_image(), dat
call psb_bcast(icontxt, dat, root) call psb_bcast(icontxt, dat, root)
@assertEqual(dat,check) @assertEqual(dat,check)
call psb_exit(icontxt) call psb_exit(icontxt)

1
test/integrationTest/test_psb_chalo.pf
Unescape Escape View File

@ -2354,7 +2354,6 @@ subroutine test_psb_chalo_tran_8imgs_vect_b(this)
!GETTING BACK X !GETTING BACK X
v = x%get_vect() v = x%get_vect()
PRINT*,'-------', ME, V
if ((me==1).or.(me==2)) then if ((me==1).or.(me==2)) then
true = 1 true = 1
else else

1
test/integrationTest/test_psb_dhalo.pf
Unescape Escape View File

@ -2350,7 +2350,6 @@ subroutine test_psb_dhalo_tran_8imgs_vect_b(this)
!GETTING BACK X !GETTING BACK X
v = x%get_vect() v = x%get_vect()
PRINT*,'-------', ME, V
if ((me==1).or.(me==2)) then if ((me==1).or.(me==2)) then
true = 1 true = 1
else else

8
test/integrationTest/test_psb_max.pf
Unescape Escape View File

@ -416,9 +416,7 @@ subroutine test_psb_imax_s(this)
Class(CafTestMethod), intent(inout) :: this Class(CafTestMethod), intent(inout) :: this
integer :: dat, check, root, info, np, icontxt integer :: dat, check, root, info, np, icontxt
call prepare_test(dat,check,root,info, np, icontxt) call prepare_test(dat,check,root,info, np, icontxt)
print*,'dat, check before', dat, check, this_image()
call psb_max(icontxt, dat, root) call psb_max(icontxt, dat, root)
print*,'dat after', dat, this_image()
@assertEqual(dat,check) @assertEqual(dat,check)
call psb_exit(icontxt) call psb_exit(icontxt)
end subroutine test_psb_imax_s end subroutine test_psb_imax_s
@ -442,9 +440,7 @@ subroutine test_psb_dmax_s(this)
double precision :: dat, check double precision :: dat, check
integer :: root, info, np, icontxt integer :: root, info, np, icontxt
call prepare_test(dat,check,root,info, np, icontxt) call prepare_test(dat,check,root,info, np, icontxt)
print*,'dat, check before', dat, check, this_image()
call psb_max(icontxt, dat, root) call psb_max(icontxt, dat, root)
print*,'dat after', dat, this_image()
@assertEqual(dat,check) @assertEqual(dat,check)
call psb_exit(icontxt) call psb_exit(icontxt)
end subroutine test_psb_dmax_s end subroutine test_psb_dmax_s
@ -535,9 +531,7 @@ subroutine test2_psb_imax_s(this)
Class(CafTestMethod), intent(inout) :: this Class(CafTestMethod), intent(inout) :: this
integer :: dat, check, root, info, np, icontxt integer :: dat, check, root, info, np, icontxt
call prepare_test2(dat,check,root,info, np, icontxt) call prepare_test2(dat,check,root,info, np, icontxt)
print*,'dat, check before', dat, check, this_image()
call psb_max(icontxt, dat, root) call psb_max(icontxt, dat, root)
print*,'dat after', dat, this_image()
@assertEqual(dat,check) @assertEqual(dat,check)
call psb_exit(icontxt) call psb_exit(icontxt)
end subroutine test2_psb_imax_s end subroutine test2_psb_imax_s
@ -561,9 +555,7 @@ subroutine test2_psb_dmax_s(this)
double precision :: dat, check double precision :: dat, check
integer :: root, info, np, icontxt integer :: root, info, np, icontxt
call prepare_test2(dat,check,root,info, np, icontxt) call prepare_test2(dat,check,root,info, np, icontxt)
print*,'dat, check before', dat, check, this_image()
call psb_max(icontxt, dat, root) call psb_max(icontxt, dat, root)
print*,'dat after', dat, this_image()
@assertEqual(dat,check) @assertEqual(dat,check)
call psb_exit(icontxt) call psb_exit(icontxt)
end subroutine test2_psb_dmax_s end subroutine test2_psb_dmax_s

1
test/integrationTest/test_psb_shalo.pf
Unescape Escape View File

@ -2350,7 +2350,6 @@ subroutine test_psb_shalo_tran_8imgs_vect_b(this)
!GETTING BACK X !GETTING BACK X
v = x%get_vect() v = x%get_vect()
PRINT*,'-------', ME, V
if ((me==1).or.(me==2)) then if ((me==1).or.(me==2)) then
true = 1 true = 1
else else

1
test/integrationTest/test_psb_zhalo.pf
Unescape Escape View File

@ -2354,7 +2354,6 @@ subroutine test_psb_zhalo_tran_8imgs_vect_b(this)
!GETTING BACK X !GETTING BACK X
v = x%get_vect() v = x%get_vect()
PRINT*,'-------', ME, V
if ((me==1).or.(me==2)) then if ((me==1).or.(me==2)) then
true = 1 true = 1
else else

2
test/pargen/Makefile
Unescape Escape View File

@ -4,7 +4,7 @@ include $(INCDIR)/Make.inc.psblas
# #
# Libraries used # Libraries used
LIBDIR=$(BASEDIR)/lib LIBDIR=$(BASEDIR)/lib
PSBLAS_LIB= -L$(LIBDIR) -L/opencoarrays6.2 -lcaf_mpi -lpsb_util -lpsb_krylov -lpsb_prec -lpsb_base PSBLAS_LIB= -L$(LIBDIR) -L/opencoarrays6.2 -lcaf_mpi -lpsb_util -lpsb_krylov -lpsb_prec -lpsb_base
LDLIBS=$(PSBLDLIBS) LDLIBS=$(PSBLDLIBS)
# #
# Compilers and such # Compilers and such

7
test/pargen/ppde2d.f90
Unescape Escape View File

@ -136,7 +136,7 @@ program ppde2d
integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst
integer(psb_long_int_k_) :: amatsize, precsize, descsize, d2size integer(psb_long_int_k_) :: amatsize, precsize, descsize, d2size
real(psb_dpk_) :: err, eps real(psb_dpk_) :: err, eps
real(psb_dpk_), allocatable :: v(:)
! other variables ! other variables
integer(psb_ipk_) :: info, i integer(psb_ipk_) :: info, i
character(len=20) :: name,ch_err character(len=20) :: name,ch_err
@ -216,6 +216,11 @@ program ppde2d
call psb_krylov(kmethd,a,prec,bv,xxv,eps,desc_a,info,& call psb_krylov(kmethd,a,prec,bv,xxv,eps,desc_a,info,&
& itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst)
if (iam == psb_root_) then
fname="sol.mtx"
v=xxv%get_vect()
call mm_array_write(v,"exact solution", info,iunit=138, filename=fname)
endif
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='solver routine' ch_err='solver routine'

6
test/pargen/ppde3d.f90
Unescape Escape View File

@ -147,6 +147,7 @@ program ppde3d
integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst
integer(psb_long_int_k_) :: amatsize, precsize, descsize, d2size integer(psb_long_int_k_) :: amatsize, precsize, descsize, d2size
real(psb_dpk_) :: err, eps real(psb_dpk_) :: err, eps
real(psb_dpk_), allocatable :: v(:)
! other variables ! other variables
integer(psb_ipk_) :: info, i integer(psb_ipk_) :: info, i
@ -236,6 +237,11 @@ program ppde3d
eps = 1.d-9 eps = 1.d-9
call psb_krylov(kmethd,a,prec,bv,xxv,eps,desc_a,info,& call psb_krylov(kmethd,a,prec,bv,xxv,eps,desc_a,info,&
& itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst)
if (iam == psb_root_) then
fname="sol3d.mtx"
v=xxv%get_vect()
call mm_array_write(v,"exact solution", info,iunit=138, filename=fname)
endif
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_

4
test/pargen/runs/ppde.inp
Unescape Escape View File

@ -2,8 +2,10 @@
BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES
BJAC Preconditioner NONE DIAG BJAC BJAC Preconditioner NONE DIAG BJAC
CSR Storage format for matrix A: CSR COO JAD CSR Storage format for matrix A: CSR COO JAD
700 Domain size (acutal system is this**3) 10 Domain size (acutal system is this**3)
2 Stopping criterion 2 Stopping criterion
0404 MAXIT 0404 MAXIT
-1 ITRACE -1 ITRACE
002 IRST restart for RGMRES and BiCGSTABL 002 IRST restart for RGMRES and BiCGSTABL

39
test/unitTest/Makefile
Unescape Escape View File

@ -1,39 +0,0 @@
BASEDIR=../..
INCDIR=$(BASEDIR)/include
include $(INCDIR)/Make.inc.psblas
#
# Libraries used
PFUNIT = /opt/pfunit/pfunit-coarrays-last
FFLAGS += -I$(INCDIR) -I$(PFUNIT)/mod -ISuites
LIBDIR=$(BASEDIR)/lib
PSBLAS_LIB= -L/opencoarrays6.2 -L$(LIBDIR) -lcaf_mpi -lpsb_util -lpsb_base -llapack -lblas
LDLIBS=$(PSBLDLIBS)
#
# Compilers and such
#
CCOPT= -g
FINCLUDES=$(FMFLAG)$(INCDIR) $(FMFLAG).
all: test_psb_swapdata
%: %.x
mpirun -np 12 ./$^
%.x:%.o driver.o
$(FCFLAGS)$(F90LINK) -g $(LOPT) -o $@ $^ -L$(PFUNIT)/lib $(PSBLAS_LIB) $(LDLIBS) -DUSE_CAF -lpfunit -lmpi
#Create .F90 file
%.F90: %.pf
$(PFUNIT)/bin/pFUnitParser.py $< $@ -lmpi
#Create .o file
%.o: %.F90
$(FC) -g -DUSE_PFUNIT -DUSE_CAF -c $(FFLAGS) $(FPPFLAGS) $^ $(PFUNIT)/include/driver.F90 -L$(PFUNIT)/lib $(PSBLAS_LIB) $(LDLIBS) -lpfunit -lmpi
clean:
/bin/rm -f *.F90 *.o *.mod
verycleanlib:
(cd ../..; make veryclean)
lib:
(cd ../../; make library)

1
test/unitTest/Suites/testSuites.inc
Unescape Escape View File

@ -1 +0,0 @@
ADD_TEST_SUITE(test_psb_swapdata_suite)

1631
test/unitTest/test_psb_swapdata.pf
View File

File diff suppressed because it is too large Load Diff

103
util/psb_d_mat_dist_impl.f90
Unescape Escape View File

@ -83,6 +83,8 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,&
! !
use psb_base_mod use psb_base_mod
use psb_mat_mod use psb_mat_mod
use iso_fortran_env
use psb_caf_mod
implicit none implicit none
! parameters ! parameters
@ -113,6 +115,14 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,&
integer(psb_ipk_), parameter :: nb=30 integer(psb_ipk_), parameter :: nb=30
real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 real(psb_dpk_) :: t0, t1, t2, t3, t4, t5
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
!logical, parameter :: if_caf=.true.
!CAF variables
integer(psb_ipk_), allocatable :: b_irow(:)[:],b_icol(:)[:]
real(psb_dpk_), allocatable :: b_val(:)[:]
integer(psb_ipk_), save :: b_ll[*], b_nnr[*]
type(event_type), save :: ll_done[*], transf_done[*]
info = psb_success_ info = psb_success_
err = 0 err = 0
@ -247,6 +257,94 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,&
! now we should insert rows i_count..j_count-1 ! now we should insert rows i_count..j_count-1
nnr = j_count - i_count nnr = j_count - i_count
if (if_caf) then
if (iam == root) then
ll = 0
do i= i_count, j_count-1
call a_glob%csget(i,i,nz,&
& irow,icol,val,info,nzin=ll,append=.true.)
if (info /= psb_success_) then
if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then
write(psb_err_unit,*) 'Allocation failure? This should not happen!'
end if
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
ll = ll + nz
end do
if (allocated(b_val)) deallocate(b_val)
if (allocated(b_irow)) deallocate(b_irow)
if (allocated(b_icol)) deallocate(b_icol)
allocate(b_val(ll)[*], b_irow(ll)[*], b_icol(ll)[*])
do k_count = 1, np_sharing
iproc = iwork(k_count)
!print*,'np_sharing', np_sharing
if (iproc == iam) then
call psb_spins(ll,irow,icol,val,a,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_spins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
b_ll[iproc + 1]=ll
b_nnr[iproc + 1]=nnr
event post(ll_done[iproc+1])
!print*,'root has post ll_done for', iproc+1
b_val(1:ll)=val(1:ll)
b_irow(1:ll)=irow(1:ll)
b_icol(1:ll)=icol(1:ll)
event post(transf_done[iproc+1])
!print*,'root has post transf_done for', iproc+1
endif
end do
else if (iam /= root) then
if (allocated(b_val)) deallocate(b_val)
if (allocated(b_irow)) deallocate(b_irow)
if (allocated(b_icol)) deallocate(b_icol)
allocate(b_val(1)[*], b_irow(1)[*], b_icol(1)[*])
do k_count = 1, np_sharing
iproc = iwork(k_count)
if (iproc == iam) then
!print*,iproc+1,' waiting for ll_done', np_sharing
event wait(ll_done)
!print*,iproc+1,'stopped waiting for ll_done'
ll = b_ll
nnr = b_nnr
if (ll > size(irow)) then
write(psb_err_unit,*) iam,'need to reallocate ',ll
deallocate(val,irow,icol)
allocate(val(ll),irow(ll),icol(ll),stat=info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
endif
!print*,iproc+1,' waiting for transf_done'
event wait(transf_done)
!print*,iproc+1,'stopped waiting for transf_done'
val(1:ll)=b_val(1:ll)[root+1]
icol(1:ll)=b_icol(1:ll)[root+1]
irow(1:ll)=b_irow(1:ll)[root+1]
call psb_spins(ll,irow,icol,val,a,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psspins'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
endif
end do
endif
else
if (iam == root) then if (iam == root) then
ll = 0 ll = 0
@ -280,7 +378,7 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,&
call psb_snd(ictxt,irow(1:ll),iproc) call psb_snd(ictxt,irow(1:ll),iproc)
call psb_snd(ictxt,icol(1:ll),iproc) call psb_snd(ictxt,icol(1:ll),iproc)
call psb_snd(ictxt,val(1:ll),iproc) call psb_snd(ictxt,val(1:ll),iproc)
call psb_rcv(ictxt,ll,iproc) !call psb_rcv(ictxt,ll,iproc)
endif endif
end do end do
else if (iam /= root) then else if (iam /= root) then
@ -305,7 +403,7 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,&
call psb_rcv(ictxt,irow(1:ll),root) call psb_rcv(ictxt,irow(1:ll),root)
call psb_rcv(ictxt,icol(1:ll),root) call psb_rcv(ictxt,icol(1:ll),root)
call psb_rcv(ictxt,val(1:ll),root) call psb_rcv(ictxt,val(1:ll),root)
call psb_snd(ictxt,ll,root) !call psb_snd(ictxt,ll,root)
call psb_spins(ll,irow,icol,val,a,desc_a,info) call psb_spins(ll,irow,icol,val,a,desc_a,info)
if(info /= psb_success_) then if(info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
@ -316,6 +414,7 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,&
endif endif
end do end do
endif endif
endif
i_count = j_count i_count = j_count
end do end do

Write Preview
Loading…
Cancel
Save