diff --git a/base/comm/internals/psi_covrl_restr.f90 b/base/comm/internals/psi_covrl_restr.f90 index 9a0ecbed..9e1c8635 100644 --- a/base/comm/internals/psi_covrl_restr.f90 +++ b/base/comm/internals/psi_covrl_restr.f90 @@ -35,90 +35,90 @@ ! ! ! -subroutine psi_covrl_restr_vect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_covrl_restr_vect - use psb_c_base_vect_mod - - implicit none - - class(psb_c_base_vect_type) :: x - complex(psb_spk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_covrl_restr_vect' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,czero) - - call psb_erractionrestore(err_act) - return +submodule (psi_c_comm_v_mod) psi_c_ovrl_restr_v_impl + use psb_base_mod +contains + module subroutine psi_covrl_restr_vect(x,xs,desc_a,info) + + implicit none + + class(psb_c_base_vect_type) :: x + complex(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_covrl_restr_vect' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,czero) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_covrl_restr_vect + return + end subroutine psi_covrl_restr_vect -subroutine psi_covrl_restr_multivect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_covrl_restr_multivect - use psb_c_base_vect_mod + module subroutine psi_covrl_restr_multivect(x,xs,desc_a,info) - implicit none + implicit none - class(psb_c_base_multivect_type) :: x - complex(psb_spk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type) :: x + complex(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz,nc - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz,nc + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err - name='psi_covrl_restr_mv' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif + name='psi_covrl_restr_mv' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif - isz = size(desc_a%ovrlap_elem,1) - call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,czero) + isz = size(desc_a%ovrlap_elem,1) + call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,czero) - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_covrl_restr_multivect + return + end subroutine psi_covrl_restr_multivect +end submodule psi_c_ovrl_restr_v_impl diff --git a/base/comm/internals/psi_covrl_restr_a.f90 b/base/comm/internals/psi_covrl_restr_a.f90 index 0ad65753..6d4a4cad 100644 --- a/base/comm/internals/psi_covrl_restr_a.f90 +++ b/base/comm/internals/psi_covrl_restr_a.f90 @@ -34,98 +34,100 @@ ! for the transpose matrix-vector product when there is a nonempty overlap. ! ! -subroutine psi_covrl_restrr1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_covrl_restrr1 - - implicit none - - complex(psb_spk_), intent(inout) :: x(:) - complex(psb_spk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_covrl_restrr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return +submodule (psi_c_comm_a_mod) psi_c_ovrl_restr_a_impl + use psb_base_mod +contains + module subroutine psi_covrl_restrr1(x,xs,desc_a,info) + + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_covrl_restrr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_covrl_restrr1 + return + end subroutine psi_covrl_restrr1 -subroutine psi_covrl_restrr2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_covrl_restrr2 + module subroutine psi_covrl_restrr2(x,xs,desc_a,info) - implicit none + implicit none - complex(psb_spk_), intent(inout) :: x(:,:) - complex(psb_spk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), intent(inout) :: x(:,:) + complex(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err - name='psi_covrl_restrr2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif + name='psi_covrl_restrr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif - if (size(x,2) /= size(xs,2)) then - info = psb_err_internal_error_ - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif + if (size(x,2) /= size(xs,2)) then + info = psb_err_internal_error_ + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif - isz = size(desc_a%ovrlap_elem,1) + isz = size(desc_a%ovrlap_elem,1) - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_covrl_restrr2 + return + end subroutine psi_covrl_restrr2 +end submodule psi_c_ovrl_restr_a_impl diff --git a/base/comm/internals/psi_covrl_save.f90 b/base/comm/internals/psi_covrl_save.f90 index 42f2ae3a..5891a202 100644 --- a/base/comm/internals/psi_covrl_save.f90 +++ b/base/comm/internals/psi_covrl_save.f90 @@ -34,103 +34,101 @@ ! for the transpose matrix-vector product when there is a nonempty overlap. ! ! -subroutine psi_covrl_save_vect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_covrl_save_vect - use psb_realloc_mod - use psb_c_base_vect_mod - - implicit none - - class(psb_c_base_vect_type) :: x - complex(psb_spk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_dovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) - - call psb_erractionrestore(err_act) - return +submodule (psi_c_comm_v_mod) psi_c_ovrl_save_v_impl + use psb_base_mod +contains + module subroutine psi_covrl_save_vect(x,xs,desc_a,info) + + implicit none + + class(psb_c_base_vect_type) :: x + complex(psb_spk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_covrl_save_vect - -subroutine psi_covrl_save_multivect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_covrl_save_multivect - use psb_realloc_mod - use psb_c_base_vect_mod - - implicit none - - class(psb_c_base_multivect_type) :: x - complex(psb_spk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, nc - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_dovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = x%get_ncols() - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_covrl_save_vect + + module subroutine psi_covrl_save_multivect(x,xs,desc_a,info) + + implicit none + + class(psb_c_base_multivect_type) :: x + complex(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, nc + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_covrl_save_multivect + return + end subroutine psi_covrl_save_multivect +end submodule psi_c_ovrl_save_v_impl diff --git a/base/comm/internals/psi_covrl_save_a.f90 b/base/comm/internals/psi_covrl_save_a.f90 index 6910a2a4..c50676e8 100644 --- a/base/comm/internals/psi_covrl_save_a.f90 +++ b/base/comm/internals/psi_covrl_save_a.f90 @@ -34,108 +34,104 @@ ! These subroutines save the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap. ! -subroutine psi_covrl_saver1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_covrl_saver1 - - use psb_realloc_mod - - implicit none - - complex(psb_spk_), intent(inout) :: x(:) - complex(psb_spk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_covrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return +submodule (psi_c_comm_a_mod) psi_c_ovrl_save_a_impl + use psb_base_mod +contains + module subroutine psi_covrl_saver1(x,xs,desc_a,info) + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_covrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_covrl_saver1 - - -subroutine psi_covrl_saver2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_covrl_saver2 - - use psb_realloc_mod - - implicit none - - complex(psb_spk_), intent(inout) :: x(:,:) - complex(psb_spk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_covrl_saver2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_covrl_saver1 + + + module subroutine psi_covrl_saver2(x,xs,desc_a,info) + implicit none + + complex(psb_spk_), intent(inout) :: x(:,:) + complex(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_covrl_saver2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_covrl_saver2 + return + end subroutine psi_covrl_saver2 +end submodule psi_c_ovrl_save_a_impl diff --git a/base/comm/internals/psi_covrl_upd.f90 b/base/comm/internals/psi_covrl_upd.f90 index 8212895c..28a7d107 100644 --- a/base/comm/internals/psi_covrl_upd.f90 +++ b/base/comm/internals/psi_covrl_upd.f90 @@ -36,169 +36,167 @@ ! ! ! -subroutine psi_covrl_upd_vect(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_covrl_upd_vect - use psb_realloc_mod - use psb_c_base_vect_mod - - implicit none - - class(psb_c_base_vect_type) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - complex(psb_spk_), allocatable :: xs(:) - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, nx, ndm - integer(psb_ipk_) :: err_act, i, idx - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - - name='psi_covrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - nx = size(desc_a%ovrlap_elem,1) - call psb_realloc(nx,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_Dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - if (update /= psb_sum_) then - call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) - ! switch on update type - - select case (update) - case(psb_square_root_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i) = xs(i)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i) = xs(i)/real(ndm) - end do - case(psb_setzero_) - do i=1,nx - if (me /= desc_a%ovrlap_elem(i,3))& - & xs(i) = czero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) +submodule (psi_c_comm_v_mod) psi_c_ovrl_upd_v_impl + use psb_base_mod +contains + module subroutine psi_covrl_upd_vect(x,desc_a,update,info) + + implicit none + + class(psb_c_base_vect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + complex(psb_spk_), allocatable :: xs(:) + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, nx, ndm + integer(psb_ipk_) :: err_act, i, idx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_covrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end select - call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,czero) - end if - - call psb_erractionrestore(err_act) - return + endif + nx = size(desc_a%ovrlap_elem,1) + call psb_realloc(nx,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i) = czero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,czero) + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_covrl_upd_vect - -subroutine psi_covrl_upd_multivect(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_covrl_upd_multivect - use psb_realloc_mod - use psb_c_base_vect_mod - - implicit none - - class(psb_c_base_multivect_type) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - complex(psb_spk_), allocatable :: xs(:,:) - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, ndm, nx, nc - integer(psb_ipk_) :: err_act, i, idx - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - - name='psi_covrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - nx = size(desc_a%ovrlap_elem,1) - nc = x%get_ncols() - call psb_realloc(nx,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_Dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - if (update /= psb_sum_) then - call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) - ! switch on update type - - select case (update) - case(psb_square_root_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i,:) = xs(i,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i,:) = xs(i,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,nx - if (me /= desc_a%ovrlap_elem(i,3))& - & xs(i,:) = czero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) + return + end subroutine psi_covrl_upd_vect + + module subroutine psi_covrl_upd_multivect(x,desc_a,update,info) + + implicit none + + class(psb_c_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + complex(psb_spk_), allocatable :: xs(:,:) + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, ndm, nx, nc + integer(psb_ipk_) :: err_act, i, idx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_covrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end select - call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,czero) - end if - - call psb_erractionrestore(err_act) - return + endif + nx = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(nx,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i,:) = czero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,czero) + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_covrl_upd_multivect + return + end subroutine psi_covrl_upd_multivect +end submodule psi_c_ovrl_upd_v_impl diff --git a/base/comm/internals/psi_covrl_upd_a.f90 b/base/comm/internals/psi_covrl_upd_a.f90 index 813cd88b..f2f2df08 100644 --- a/base/comm/internals/psi_covrl_upd_a.f90 +++ b/base/comm/internals/psi_covrl_upd_a.f90 @@ -32,143 +32,143 @@ ! Subroutine: psi_covrl_update ! These subroutines update the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap, -! or for the application of Additive Schwarz preconditioners. +! or for the application of Additive Schwarz preconditioners. ! ! -subroutine psi_covrl_updr1(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_covrl_updr1 - - implicit none - - complex(psb_spk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_covrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = czero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return +submodule (psi_c_comm_a_mod) psi_c_ovrl_upd_a_impl + use psb_base_mod +contains + module subroutine psi_covrl_updr1(x,desc_a,update,info) + implicit none + + complex(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_covrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = czero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_covrl_updr1 - -subroutine psi_covrl_updr2(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_covrl_updr2 - - implicit none - - complex(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_covrl_updr2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = czero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_covrl_updr1 + + module subroutine psi_covrl_updr2(x,desc_a,update,info) + implicit none + + complex(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_covrl_updr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = czero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_covrl_updr2 + return + end subroutine psi_covrl_updr2 +end submodule psi_c_ovrl_upd_a_impl diff --git a/base/comm/internals/psi_cswapdata.F90 b/base/comm/internals/psi_cswapdata.F90 index 9bfc36e9..4d6be418 100644 --- a/base/comm/internals/psi_cswapdata.F90 +++ b/base/comm/internals/psi_cswapdata.F90 @@ -89,676 +89,659 @@ ! ! ! -subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data) +submodule (psi_c_comm_v_mod) psi_c_swapdata_impl + use psb_base_mod +contains + subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_cswapdata_vect - use psb_c_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_c_base_vect_type) :: y - complex(psb_spk_) :: beta - complex(psb_spk_), target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_vect_type) :: y + complex(psb_spk_) :: beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) return -end subroutine psi_cswapdata_vect +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_cswapdata_vect + + + ! + ! + ! Subroutine: psi_cswap_vidx_vect + ! Data exchange among processes. + ! + ! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods + ! of vectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_cswap_vidx_vect(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_cswap_vidx_vect -! Data exchange among processes. -! -! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods -! of vectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_cswap_vidx_vect(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_cswap_vidx_vect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_c_base_vect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_c_base_vect_type) :: y - complex(psb_spk_) :: beta - complex(psb_spk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, nesd, nerv - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, n - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_vect_type) :: y + complex(psb_spk_) :: beta + complex(psb_spk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),& + & iret, nesd, nerv + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + rcv_pt = 1+pnti+psb_n_elem_recv_ + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_complex_swap_tag + call mpi_irecv(y%combuf(rcv_pt),nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + idx_pt = snd_pt + call y%gth(idx_pt,nesd,idx) + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_complex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - p2ptag = psb_complex_swap_tag - call mpi_irecv(y%combuf(rcv_pt),nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - pnti = pnti + nerv + nesd + 3 - end do - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - idx_pt = snd_pt - call y%gth(idx_pt,nesd,idx) - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - p2ptag = psb_complex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if ((nesd>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(snd_pt),nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - p2ptag = psb_complex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (proc_to_comm /= me)then - if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_complex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) + call y%sct(rcv_pt,nerv,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(rcv_pt:rcv_pt+nerv-1) - call y%sct(rcv_pt,nerv,idx,beta) - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for everybody, clean up - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_cswap_vidx_vect - -! -! -! Subroutine: psi_cswapdata_multivect -! Data exchange among processes. -! -! Takes care of Y an encaspulated multivector. -! -! -subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_cswapdata_multivect - use psb_c_base_multivect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_cswap_vidx_vect + + ! + ! + ! Subroutine: psi_cswapdata_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_c_base_multivect_type) :: y - complex(psb_spk_) :: beta - complex(psb_spk_), target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type) :: y + complex(psb_spk_) :: beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) return -end subroutine psi_cswapdata_multivect +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_cswapdata_multivect + + + ! + ! + ! Subroutine: psi_cswap_vidx_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods + ! of multivectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_cswap_vidx_multivect(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_cswap_vidx_multivect -! Data exchange among processes. -! -! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods -! of multivectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_cswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_cswap_vidx_multivect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_c_base_multivect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_c_base_multivect_type) :: y - complex(psb_spk_) :: beta - complex(psb_spk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n = y%get_ncols() - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type) :: y + complex(psb_spk_) :: beta + complex(psb_spk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + n = y%get_ncols() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_complex_swap_tag + call mpi_irecv(y%combuf(rcv_pt),n*nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call y%gth(idx_pt,snd_pt,nesd,idx) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait for device + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_complex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),n*nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - p2ptag = psb_complex_swap_tag - call mpi_irecv(y%combuf(rcv_pt),n*nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call y%gth(idx_pt,snd_pt,nesd,idx) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait for device - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_complex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - if ((nesd>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(snd_pt),n*nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_complex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm /= me)then - if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_complex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+n*nerv-1) + call y%sct(idx_pt,rcv_pt,nerv,idx,beta) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(rcv_pt:rcv_pt+n*nerv-1) - call y%sct(idx_pt,rcv_pt,nerv,idx,beta) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for com, cleanup comid - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_cswap_vidx_multivect + return + end subroutine psi_cswap_vidx_multivect +end submodule psi_c_swapdata_impl diff --git a/base/comm/internals/psi_cswapdata_a.F90 b/base/comm/internals/psi_cswapdata_a.F90 index 19a68842..709a0d62 100644 --- a/base/comm/internals/psi_cswapdata_a.F90 +++ b/base/comm/internals/psi_cswapdata_a.F90 @@ -84,912 +84,899 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) +submodule (psi_c_comm_a_mod) psi_c_swapdata_a_impl + use psb_base_mod +contains + module subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_cswapdatam - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:,:), beta - complex(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info +complex(psb_spk_) :: y(:,:), beta +complex(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_cswapdatam + end subroutine psi_cswapdatam -subroutine psi_cswapidxm(ctxt,icomm,flag,n,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) + module subroutine psi_cswapidxm(ctxt,flag,n,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) - use psi_mod, psb_protect_name => psi_cswapidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:,:), beta - complex(psb_spk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - - integer(psb_mpk_) :: np, me, nesd, nerv - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info +complex(psb_spk_) :: y(:,:), beta +complex(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + + integer(psb_mpk_) :: np, me, nesd, nerv + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_mpk_) :: icomm + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + +complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if - ! prepare info for communications + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + end if - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_c_spk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_c_spk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_complex_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_c_spk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_c_spk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_complex_swap_tag + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_complex_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*)& + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_sync) then - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + else if (swap_send) then - if (proc_to_comm < me) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - end do + end if + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then + end if - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_complex_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_complex_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),n*nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),n*nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,iret) - end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_complex_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*)& - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_cswapidxm + end subroutine psi_cswapidxm + + ! + ! + ! Subroutine: psi_cswapdatav + ! Implements the data exchange among processes. Essentially this is doing + ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but + ! it is capable of pruning empty exchanges, which are very likely in out + ! application environment. All the variants have the same structure + ! In all these subroutines X may be: I Integer + ! S real(psb_spk_) + ! D real(psb_dpk_) + ! C complex(psb_spk_) + ! Z complex(psb_dpk_) + ! Basically the operation is as follows: on each process, we identify + ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); + ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y + ! but only on the elements involved in the UNPACK operation. + ! Thus: for halo data exchange, the receive section is confined in the + ! halo indices, and BETA=0, whereas for overlap exchange the receive section + ! is scattered in the owned indices, and BETA=1. + ! The first routine picks the desired exchange index list and passes it to the second. + ! + ! Arguments: + ! flag - integer Choose the algorithm for data exchange: + ! this is chosen through bit fields. + ! 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 + ! if (swap_mpi): use underlying MPI_ALLTOALLV. + ! if (swap_sync): use PSB_SND and PSB_RCV in + ! synchronized pairs + ! if (swap_send .and. swap_recv): use mpi_irecv + ! and mpi_send + ! if (swap_send): use psb_snd (but need another + ! call with swap_recv to complete) + ! if (swap_recv): use psb_rcv (completing a + ! previous call with swap_send) + ! + ! + ! n - integer Number of columns in Y + ! beta - complex Choose overwrite or sum. + ! y(:) - complex The data area + ! desc_a - type(psb_desc_type). The communication descriptor. + ! work(:) - complex Buffer space. If not sufficient, will do + ! our own internal allocation. + ! info - integer. return code. + ! data - integer which list is to be used to exchange data + ! default psb_comm_halo_ + ! psb_comm_halo_ use halo_index + ! psb_comm_ext_ use ext_index + ! psb_comm_ovrl_ use ovrl_index + ! psb_comm_mov_ use ovr_mst_idx + ! + ! + module subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) -! -! -! Subroutine: psi_cswapdatav -! Implements the data exchange among processes. Essentially this is doing -! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! The first routine picks the desired exchange index list and passes it to the second. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! 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 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - complex Choose overwrite or sum. -! y(:) - complex The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - complex Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_cswapdatav - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:), beta - complex(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif - return -end subroutine psi_cswapdatav + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if -! -! -! Subroutine: psi_cswapdataidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_cswapidxv(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) + call psi_swapdata(ctxt,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) - use psi_mod, psb_protect_name => psi_cswapidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_cswapdatav + + + ! + ! + ! Subroutine: psi_cswapdataidxv + ! Does the data exchange among processes. + ! + ! The real workhorse: the outer routines will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_cswapidxv(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psb_error_mod + use psb_desc_mod + use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:), beta - complex(psb_spk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + integer(psb_mpk_) :: icomm + logical, parameter :: usersend=.false. + + complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications + ! prepare info for communications - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - end do + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - end if - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_c_spk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_c_spk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. end if - else if (swap_sync) then - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + if (do_send) then - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_c_spk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_c_spk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_complex_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_complex_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_complex_swap_tag - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_complex_swap_tag + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_complex_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,iret) + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) end if + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_complex_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_cswapidxv + end subroutine psi_cswapidxv +end submodule psi_c_swapdata_a_impl diff --git a/base/comm/internals/psi_cswaptran.F90 b/base/comm/internals/psi_cswaptran.F90 index 3cb93309..92b9f326 100644 --- a/base/comm/internals/psi_cswaptran.F90 +++ b/base/comm/internals/psi_cswaptran.F90 @@ -91,418 +91,406 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data) +submodule (psi_c_comm_v_mod) psi_c_swaptran_impl + use psb_base_mod +contains + module subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_cswaptran_vect - use psb_c_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_c_base_vect_type) :: y - complex(psb_spk_) :: beta - complex(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_vect_type) :: y + complex(psb_spk_) :: beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_cswaptran_vect + end subroutine psi_cswaptran_vect + + ! + ! + ! Subroutine: psi_ctran_vidx_vect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated vector. Relies on the gather/scatter methods + ! of vectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_ctran_vidx_vect(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_ctran_vidx_vect -! Data exchange among processes. -! -! Takes care of Y an encapsulated vector. Relies on the gather/scatter methods -! of vectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_ctran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_ctran_vidx_vect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_c_base_vect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_c_base_vect_type) :: y - complex(psb_spk_) :: beta - complex(psb_spk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - p2ptag = psb_complex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - call mpi_irecv(y%combuf(snd_pt),nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - idx_pt = rcv_pt - call y%gth(idx_pt,nerv,idx) - - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - p2ptag = psb_complex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if ((nerv>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(rcv_pt),nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_vect_type) :: y + complex(psb_spk_) :: beta + complex(psb_spk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + p2ptag = psb_complex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + call mpi_irecv(y%combuf(snd_pt),nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + idx_pt = rcv_pt + call y%gth(idx_pt,nerv,idx) + + pnti = pnti + nerv + nesd + 3 + end do - pnti = pnti + nerv + nesd + 3 - end do - end if + ! + ! Then wait + ! + call y%device_wait() - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... + if (debug) write(*,*) me,' isend' ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_complex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - p2ptag = psb_complex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (proc_to_comm /= me)then - if (nerv>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_complex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+nesd-1) + call y%sct(snd_pt,nesd,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(snd_pt:snd_pt+nesd-1) - call y%sct(snd_pt,nesd,idx,beta) - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for everybody, clean up - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return + return -end subroutine psi_ctran_vidx_vect + end subroutine psi_ctran_vidx_vect -! -! -! -! -! Subroutine: psi_cswaptran_multivect -! Data exchange among processes. -! -! Takes care of Y an encaspulated multivector. -! -! -subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data) + ! + ! + ! + ! + ! Subroutine: psi_cswaptran_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_cswaptran_multivect - use psb_c_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_c_base_multivect_type) :: y - complex(psb_spk_) :: beta - complex(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type) :: y + complex(psb_spk_) :: beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) @@ -510,273 +498,266 @@ subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data) end subroutine psi_cswaptran_multivect -! -! -! Subroutine: psi_ctran_vidx_multivect -! Data exchange among processes. -! -! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods -! of multivectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_ctran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_ctran_vidx_multivect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_c_base_multivect_mod + ! + ! + ! Subroutine: psi_ctran_vidx_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods + ! of multivectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_ctran_vidx_multivect(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_c_base_multivect_type) :: y - complex(psb_spk_) :: beta - complex(psb_spk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n = y%get_ncols() - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_c_base_multivect_type) :: y + complex(psb_spk_) :: beta + complex(psb_spk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + n = y%get_ncols() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_complex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt + call mpi_irecv(y%combuf(snd_pt),n*nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call y%gth(idx_pt,rcv_pt,nerv,idx) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait for device + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_complex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),n*nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_complex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt - call mpi_irecv(y%combuf(snd_pt),n*nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call y%gth(idx_pt,rcv_pt,nerv,idx) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait for device - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_complex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - if ((nerv>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(rcv_pt),n*nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_complex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm /= me)then - if (nerv>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_complex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(snd_pt:snd_pt+n*nesd-1) - call y%sct(idx_pt,snd_pt,nesd,idx,beta) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! - ! Waited for com, cleanup comid - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if (debug) write(*,*) me,' done' - end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+n*nesd-1) + call y%sct(idx_pt,snd_pt,nesd,idx,beta) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - call psb_erractionrestore(err_act) - return + ! + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null -9999 call psb_error_handler(ctxt,err_act) + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if - return -end subroutine psi_ctran_vidx_multivect + call psb_erractionrestore(err_act) + return +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ctran_vidx_multivect +end submodule psi_c_swaptran_impl diff --git a/base/comm/internals/psi_cswaptran_a.F90 b/base/comm/internals/psi_cswaptran_a.F90 index 0065b7f2..285a6a16 100644 --- a/base/comm/internals/psi_cswaptran_a.F90 +++ b/base/comm/internals/psi_cswaptran_a.F90 @@ -88,922 +88,909 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) +submodule (psi_c_comm_a_mod) psi_c_swaptran_a_impl + use psb_base_mod +contains + module subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_cswaptranm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:,:), beta - complex(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, err_act, totxch, data_ - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, err_act, totxch, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return -end subroutine psi_cswaptranm -subroutine psi_ctranidxm(ctxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) +9999 call psb_error_handler(ctxt,err_act) - use psi_mod, psb_protect_name => psi_ctranidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_cswaptranm + + module subroutine psi_ctranidxm(ctxt,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:,:), beta - complex(psb_spk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + integer(psb_mpk_) :: icomm + logical, parameter :: usersend=.false. + + complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if - ! prepare info for communications + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + if (do_send) then - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd + call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 end if - albf=.true. - end if - if (do_send) then - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) + ! Case SWAP_MPI + if (swap_mpi) then - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_c_spk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_c_spk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if - end if + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_complex_swap_tag + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_complex_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - ! Case SWAP_MPI - if (swap_mpi) then + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_c_spk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_c_spk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_complex_swap_tag - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send',& + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_complex_swap_tag - call mpi_irecv(sndbuf(snd_pt),n*nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + else if (swap_send) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + else if (swap_recv) then - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_complex_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,iret) - end if + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 + end if - end do + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_complex_swap_tag + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send',& - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_ctranidxm -! -! -! Subroutine: psi_cswaptranv -! Implements the data exchange among processes. This is similar to Xswapdata, but -! the list is read "in reverse", i.e. indices that are normally SENT are used -! for the RECEIVE part and vice-versa. This is the basic data exchange operation -! for doing the product of a sparse matrix by a vector. -! Essentially this is doing a variable all-to-all data exchange -! (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! The first routine picks the desired exchange index list and passes it to the second. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! 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 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - complex Choose overwrite or sum. -! y(:) - complex The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - complex Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_cswaptranv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + end subroutine psi_ctranidxm + ! + ! + ! Subroutine: psi_cswaptranv + ! Implements the data exchange among processes. This is similar to Xswapdata, but + ! the list is read "in reverse", i.e. indices that are normally SENT are used + ! for the RECEIVE part and vice-versa. This is the basic data exchange operation + ! for doing the product of a sparse matrix by a vector. + ! Essentially this is doing a variable all-to-all data exchange + ! (ALLTOALLV in MPI parlance), but + ! it is capable of pruning empty exchanges, which are very likely in out + ! application environment. All the variants have the same structure + ! In all these subroutines X may be: I Integer + ! S real(psb_spk_) + ! D real(psb_dpk_) + ! C complex(psb_spk_) + ! Z complex(psb_dpk_) + ! Basically the operation is as follows: on each process, we identify + ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); + ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y + ! but only on the elements involved in the UNPACK operation. + ! Thus: for halo data exchange, the receive section is confined in the + ! halo indices, and BETA=0, whereas for overlap exchange the receive section + ! is scattered in the owned indices, and BETA=1. + ! The first routine picks the desired exchange index list and passes it to the second. + ! + ! Arguments: + ! flag - integer Choose the algorithm for data exchange: + ! this is chosen through bit fields. + ! 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 + ! if (swap_mpi): use underlying MPI_ALLTOALLV. + ! if (swap_sync): use PSB_SND and PSB_RCV in + ! synchronized pairs + ! if (swap_send .and. swap_recv): use mpi_irecv + ! and mpi_send + ! if (swap_send): use psb_snd (but need another + ! call with swap_recv to complete) + ! if (swap_recv): use psb_rcv (completing a + ! previous call with swap_send) + ! + ! + ! n - integer Number of columns in Y + ! beta - complex Choose overwrite or sum. + ! y(:) - complex The data area + ! desc_a - type(psb_desc_type). The communication descriptor. + ! work(:) - complex Buffer space. If not sufficient, will do + ! our own internal allocation. + ! info - integer. return code. + ! data - integer which list is to be used to exchange data + ! default psb_comm_halo_ + ! psb_comm_halo_ use halo_index + ! psb_comm_ext_ use ext_index + ! psb_comm_ovrl_ use ovrl_index + ! psb_comm_mov_ use ovr_mst_idx + ! + ! + module subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:), beta - complex(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif - return -end subroutine psi_cswaptranv + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if -! -! -! Subroutine: psi_ctranidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_ctranidxv(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) + call psi_swaptran(ctxt,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 - use psi_mod, psb_protect_name => psi_ctranidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_cswaptranv + + + ! + ! + ! Subroutine: psi_ctranidxv + ! Does the data exchange among processes. + ! + ! The real workhorse: the outer routines will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_ctranidxv(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:), beta - complex(psb_spk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_mpk_) :: icomm + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications + ! prepare info for communications - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - end do + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - end if - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_c_spk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_c_spk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - else if (swap_sync) then + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_c_spk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_c_spk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_complex_swap_tag + call mpi_irecv(sndbuf(snd_pt),nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_complex_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm < me) then + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_complex_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_complex_swap_tag - call mpi_irecv(sndbuf(snd_pt),nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + end if - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_complex_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag, icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag, icomm,iret) - end if + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_complex_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_ctranidxv + end subroutine psi_ctranidxv +end submodule psi_c_swaptran_a_impl diff --git a/base/comm/internals/psi_dovrl_restr.f90 b/base/comm/internals/psi_dovrl_restr.f90 index bbcab4f3..9bc9bed5 100644 --- a/base/comm/internals/psi_dovrl_restr.f90 +++ b/base/comm/internals/psi_dovrl_restr.f90 @@ -35,90 +35,90 @@ ! ! ! -subroutine psi_dovrl_restr_vect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_dovrl_restr_vect - use psb_d_base_vect_mod - - implicit none - - class(psb_d_base_vect_type) :: x - real(psb_dpk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_dovrl_restr_vect' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,dzero) - - call psb_erractionrestore(err_act) - return +submodule (psi_d_comm_v_mod) psi_d_ovrl_restr_v_impl + use psb_base_mod +contains + module subroutine psi_dovrl_restr_vect(x,xs,desc_a,info) + + implicit none + + class(psb_d_base_vect_type) :: x + real(psb_dpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_dovrl_restr_vect' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,dzero) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_dovrl_restr_vect + return + end subroutine psi_dovrl_restr_vect -subroutine psi_dovrl_restr_multivect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_dovrl_restr_multivect - use psb_d_base_vect_mod + module subroutine psi_dovrl_restr_multivect(x,xs,desc_a,info) - implicit none + implicit none - class(psb_d_base_multivect_type) :: x - real(psb_dpk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: x + real(psb_dpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz,nc - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz,nc + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err - name='psi_dovrl_restr_mv' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif + name='psi_dovrl_restr_mv' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif - isz = size(desc_a%ovrlap_elem,1) - call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,dzero) + isz = size(desc_a%ovrlap_elem,1) + call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,dzero) - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_dovrl_restr_multivect + return + end subroutine psi_dovrl_restr_multivect +end submodule psi_d_ovrl_restr_v_impl diff --git a/base/comm/internals/psi_dovrl_restr_a.f90 b/base/comm/internals/psi_dovrl_restr_a.f90 index 768f6b26..f197251b 100644 --- a/base/comm/internals/psi_dovrl_restr_a.f90 +++ b/base/comm/internals/psi_dovrl_restr_a.f90 @@ -34,98 +34,100 @@ ! for the transpose matrix-vector product when there is a nonempty overlap. ! ! -subroutine psi_dovrl_restrr1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_dovrl_restrr1 - - implicit none - - real(psb_dpk_), intent(inout) :: x(:) - real(psb_dpk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_dovrl_restrr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return +submodule (psi_d_comm_a_mod) psi_d_ovrl_restr_a_impl + use psb_base_mod +contains + module subroutine psi_dovrl_restrr1(x,xs,desc_a,info) + + implicit none + + real(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_dovrl_restrr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_dovrl_restrr1 + return + end subroutine psi_dovrl_restrr1 -subroutine psi_dovrl_restrr2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_dovrl_restrr2 + module subroutine psi_dovrl_restrr2(x,xs,desc_a,info) - implicit none + implicit none - real(psb_dpk_), intent(inout) :: x(:,:) - real(psb_dpk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), intent(inout) :: x(:,:) + real(psb_dpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err - name='psi_dovrl_restrr2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif + name='psi_dovrl_restrr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif - if (size(x,2) /= size(xs,2)) then - info = psb_err_internal_error_ - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif + if (size(x,2) /= size(xs,2)) then + info = psb_err_internal_error_ + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif - isz = size(desc_a%ovrlap_elem,1) + isz = size(desc_a%ovrlap_elem,1) - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_dovrl_restrr2 + return + end subroutine psi_dovrl_restrr2 +end submodule psi_d_ovrl_restr_a_impl diff --git a/base/comm/internals/psi_dovrl_save.f90 b/base/comm/internals/psi_dovrl_save.f90 index f7bc3dd1..16b37660 100644 --- a/base/comm/internals/psi_dovrl_save.f90 +++ b/base/comm/internals/psi_dovrl_save.f90 @@ -34,103 +34,101 @@ ! for the transpose matrix-vector product when there is a nonempty overlap. ! ! -subroutine psi_dovrl_save_vect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_dovrl_save_vect - use psb_realloc_mod - use psb_d_base_vect_mod - - implicit none - - class(psb_d_base_vect_type) :: x - real(psb_dpk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_dovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) - - call psb_erractionrestore(err_act) - return +submodule (psi_d_comm_v_mod) psi_d_ovrl_save_v_impl + use psb_base_mod +contains + module subroutine psi_dovrl_save_vect(x,xs,desc_a,info) + + implicit none + + class(psb_d_base_vect_type) :: x + real(psb_dpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_dovrl_save_vect - -subroutine psi_dovrl_save_multivect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_dovrl_save_multivect - use psb_realloc_mod - use psb_d_base_vect_mod - - implicit none - - class(psb_d_base_multivect_type) :: x - real(psb_dpk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, nc - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_dovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = x%get_ncols() - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_dovrl_save_vect + + module subroutine psi_dovrl_save_multivect(x,xs,desc_a,info) + + implicit none + + class(psb_d_base_multivect_type) :: x + real(psb_dpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, nc + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_dovrl_save_multivect + return + end subroutine psi_dovrl_save_multivect +end submodule psi_d_ovrl_save_v_impl diff --git a/base/comm/internals/psi_dovrl_save_a.f90 b/base/comm/internals/psi_dovrl_save_a.f90 index 25c821b8..25d754d0 100644 --- a/base/comm/internals/psi_dovrl_save_a.f90 +++ b/base/comm/internals/psi_dovrl_save_a.f90 @@ -34,108 +34,104 @@ ! These subroutines save the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap. ! -subroutine psi_dovrl_saver1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_dovrl_saver1 - - use psb_realloc_mod - - implicit none - - real(psb_dpk_), intent(inout) :: x(:) - real(psb_dpk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_dovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return +submodule (psi_d_comm_a_mod) psi_d_ovrl_save_a_impl + use psb_base_mod +contains + module subroutine psi_dovrl_saver1(x,xs,desc_a,info) + implicit none + + real(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_dovrl_saver1 - - -subroutine psi_dovrl_saver2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_dovrl_saver2 - - use psb_realloc_mod - - implicit none - - real(psb_dpk_), intent(inout) :: x(:,:) - real(psb_dpk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_dovrl_saver2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_dovrl_saver1 + + + module subroutine psi_dovrl_saver2(x,xs,desc_a,info) + implicit none + + real(psb_dpk_), intent(inout) :: x(:,:) + real(psb_dpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_dovrl_saver2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_dovrl_saver2 + return + end subroutine psi_dovrl_saver2 +end submodule psi_d_ovrl_save_a_impl diff --git a/base/comm/internals/psi_dovrl_upd.f90 b/base/comm/internals/psi_dovrl_upd.f90 index 4ca995d9..147fa47a 100644 --- a/base/comm/internals/psi_dovrl_upd.f90 +++ b/base/comm/internals/psi_dovrl_upd.f90 @@ -36,169 +36,167 @@ ! ! ! -subroutine psi_dovrl_upd_vect(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_dovrl_upd_vect - use psb_realloc_mod - use psb_d_base_vect_mod - - implicit none - - class(psb_d_base_vect_type) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - real(psb_dpk_), allocatable :: xs(:) - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, nx, ndm - integer(psb_ipk_) :: err_act, i, idx - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - - name='psi_dovrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - nx = size(desc_a%ovrlap_elem,1) - call psb_realloc(nx,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_Dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - if (update /= psb_sum_) then - call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) - ! switch on update type - - select case (update) - case(psb_square_root_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i) = xs(i)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i) = xs(i)/real(ndm) - end do - case(psb_setzero_) - do i=1,nx - if (me /= desc_a%ovrlap_elem(i,3))& - & xs(i) = dzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) +submodule (psi_d_comm_v_mod) psi_d_ovrl_upd_v_impl + use psb_base_mod +contains + module subroutine psi_dovrl_upd_vect(x,desc_a,update,info) + + implicit none + + class(psb_d_base_vect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + real(psb_dpk_), allocatable :: xs(:) + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, nx, ndm + integer(psb_ipk_) :: err_act, i, idx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_dovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end select - call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,dzero) - end if - - call psb_erractionrestore(err_act) - return + endif + nx = size(desc_a%ovrlap_elem,1) + call psb_realloc(nx,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i) = dzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,dzero) + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_dovrl_upd_vect - -subroutine psi_dovrl_upd_multivect(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_dovrl_upd_multivect - use psb_realloc_mod - use psb_d_base_vect_mod - - implicit none - - class(psb_d_base_multivect_type) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - real(psb_dpk_), allocatable :: xs(:,:) - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, ndm, nx, nc - integer(psb_ipk_) :: err_act, i, idx - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - - name='psi_dovrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - nx = size(desc_a%ovrlap_elem,1) - nc = x%get_ncols() - call psb_realloc(nx,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_Dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - if (update /= psb_sum_) then - call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) - ! switch on update type - - select case (update) - case(psb_square_root_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i,:) = xs(i,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i,:) = xs(i,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,nx - if (me /= desc_a%ovrlap_elem(i,3))& - & xs(i,:) = dzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) + return + end subroutine psi_dovrl_upd_vect + + module subroutine psi_dovrl_upd_multivect(x,desc_a,update,info) + + implicit none + + class(psb_d_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + real(psb_dpk_), allocatable :: xs(:,:) + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, ndm, nx, nc + integer(psb_ipk_) :: err_act, i, idx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_dovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end select - call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,dzero) - end if - - call psb_erractionrestore(err_act) - return + endif + nx = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(nx,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i,:) = dzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,dzero) + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_dovrl_upd_multivect + return + end subroutine psi_dovrl_upd_multivect +end submodule psi_d_ovrl_upd_v_impl diff --git a/base/comm/internals/psi_dovrl_upd_a.f90 b/base/comm/internals/psi_dovrl_upd_a.f90 index 9678d3e3..5b81d096 100644 --- a/base/comm/internals/psi_dovrl_upd_a.f90 +++ b/base/comm/internals/psi_dovrl_upd_a.f90 @@ -32,143 +32,143 @@ ! Subroutine: psi_dovrl_update ! These subroutines update the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap, -! or for the application of Additive Schwarz preconditioners. +! or for the application of Additive Schwarz preconditioners. ! ! -subroutine psi_dovrl_updr1(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_dovrl_updr1 - - implicit none - - real(psb_dpk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_dovrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = dzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return +submodule (psi_d_comm_a_mod) psi_d_ovrl_upd_a_impl + use psb_base_mod +contains + module subroutine psi_dovrl_updr1(x,desc_a,update,info) + implicit none + + real(psb_dpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_dovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = dzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_dovrl_updr1 - -subroutine psi_dovrl_updr2(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_dovrl_updr2 - - implicit none - - real(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_dovrl_updr2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = dzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_dovrl_updr1 + + module subroutine psi_dovrl_updr2(x,desc_a,update,info) + implicit none + + real(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_dovrl_updr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = dzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_dovrl_updr2 + return + end subroutine psi_dovrl_updr2 +end submodule psi_d_ovrl_upd_a_impl diff --git a/base/comm/internals/psi_dswapdata.F90 b/base/comm/internals/psi_dswapdata.F90 index c118206f..890cfc30 100644 --- a/base/comm/internals/psi_dswapdata.F90 +++ b/base/comm/internals/psi_dswapdata.F90 @@ -89,676 +89,659 @@ ! ! ! -subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data) +submodule (psi_d_comm_v_mod) psi_d_swapdata_impl + use psb_base_mod +contains + subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_dswapdata_vect - use psb_d_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_d_base_vect_type) :: y - real(psb_dpk_) :: beta - real(psb_dpk_), target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_vect_type) :: y + real(psb_dpk_) :: beta + real(psb_dpk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) return -end subroutine psi_dswapdata_vect +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_dswapdata_vect + + + ! + ! + ! Subroutine: psi_dswap_vidx_vect + ! Data exchange among processes. + ! + ! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods + ! of vectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_dswap_vidx_vect(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_dswap_vidx_vect -! Data exchange among processes. -! -! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods -! of vectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_dswap_vidx_vect(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_dswap_vidx_vect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_d_base_vect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_d_base_vect_type) :: y - real(psb_dpk_) :: beta - real(psb_dpk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, nesd, nerv - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, n - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_vect_type) :: y + real(psb_dpk_) :: beta + real(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),& + & iret, nesd, nerv + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + rcv_pt = 1+pnti+psb_n_elem_recv_ + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_double_swap_tag + call mpi_irecv(y%combuf(rcv_pt),nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + idx_pt = snd_pt + call y%gth(idx_pt,nesd,idx) + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - p2ptag = psb_double_swap_tag - call mpi_irecv(y%combuf(rcv_pt),nerv,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - pnti = pnti + nerv + nesd + 3 - end do - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - idx_pt = snd_pt - call y%gth(idx_pt,nesd,idx) - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - p2ptag = psb_double_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if ((nesd>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(snd_pt),nesd,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - p2ptag = psb_double_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (proc_to_comm /= me)then - if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_double_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) + call y%sct(rcv_pt,nerv,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(rcv_pt:rcv_pt+nerv-1) - call y%sct(rcv_pt,nerv,idx,beta) - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for everybody, clean up - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_dswap_vidx_vect - -! -! -! Subroutine: psi_dswapdata_multivect -! Data exchange among processes. -! -! Takes care of Y an encaspulated multivector. -! -! -subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_dswapdata_multivect - use psb_d_base_multivect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_dswap_vidx_vect + + ! + ! + ! Subroutine: psi_dswapdata_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_d_base_multivect_type) :: y - real(psb_dpk_) :: beta - real(psb_dpk_), target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: y + real(psb_dpk_) :: beta + real(psb_dpk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) return -end subroutine psi_dswapdata_multivect +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_dswapdata_multivect + + + ! + ! + ! Subroutine: psi_dswap_vidx_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods + ! of multivectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_dswap_vidx_multivect(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_dswap_vidx_multivect -! Data exchange among processes. -! -! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods -! of multivectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_dswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_dswap_vidx_multivect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_d_base_multivect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_d_base_multivect_type) :: y - real(psb_dpk_) :: beta - real(psb_dpk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n = y%get_ncols() - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: y + real(psb_dpk_) :: beta + real(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + n = y%get_ncols() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_double_swap_tag + call mpi_irecv(y%combuf(rcv_pt),n*nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call y%gth(idx_pt,snd_pt,nesd,idx) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait for device + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),n*nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - p2ptag = psb_double_swap_tag - call mpi_irecv(y%combuf(rcv_pt),n*nerv,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call y%gth(idx_pt,snd_pt,nesd,idx) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait for device - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_double_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - if ((nesd>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(snd_pt),n*nesd,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_double_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm /= me)then - if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+n*nerv-1) + call y%sct(idx_pt,rcv_pt,nerv,idx,beta) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(rcv_pt:rcv_pt+n*nerv-1) - call y%sct(idx_pt,rcv_pt,nerv,idx,beta) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for com, cleanup comid - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_dswap_vidx_multivect + return + end subroutine psi_dswap_vidx_multivect +end submodule psi_d_swapdata_impl diff --git a/base/comm/internals/psi_dswapdata_a.F90 b/base/comm/internals/psi_dswapdata_a.F90 index 9f1f9cec..2b10ea2d 100644 --- a/base/comm/internals/psi_dswapdata_a.F90 +++ b/base/comm/internals/psi_dswapdata_a.F90 @@ -84,912 +84,899 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) +submodule (psi_d_comm_a_mod) psi_d_swapdata_a_impl + use psb_base_mod +contains + module subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_dswapdatam - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info +real(psb_dpk_) :: y(:,:), beta +real(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_dswapdatam + end subroutine psi_dswapdatam -subroutine psi_dswapidxm(ctxt,icomm,flag,n,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) + module subroutine psi_dswapidxm(ctxt,flag,n,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) - use psi_mod, psb_protect_name => psi_dswapidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - - integer(psb_mpk_) :: np, me, nesd, nerv - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info +real(psb_dpk_) :: y(:,:), beta +real(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + + integer(psb_mpk_) :: np, me, nesd, nerv + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_mpk_) :: icomm + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + +real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if - ! prepare info for communications + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + end if - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_r_dpk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_r_dpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_double_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_r_dpk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_r_dpk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_double_swap_tag + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_double_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*)& + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_sync) then - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + else if (swap_send) then - if (proc_to_comm < me) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - end do + end if + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then + end if - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_double_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_double_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),n*nesd,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),n*nesd,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,iret) - end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_double_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*)& - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_dswapidxm + end subroutine psi_dswapidxm + + ! + ! + ! Subroutine: psi_dswapdatav + ! Implements the data exchange among processes. Essentially this is doing + ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but + ! it is capable of pruning empty exchanges, which are very likely in out + ! application environment. All the variants have the same structure + ! In all these subroutines X may be: I Integer + ! S real(psb_spk_) + ! D real(psb_dpk_) + ! C complex(psb_spk_) + ! Z complex(psb_dpk_) + ! Basically the operation is as follows: on each process, we identify + ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); + ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y + ! but only on the elements involved in the UNPACK operation. + ! Thus: for halo data exchange, the receive section is confined in the + ! halo indices, and BETA=0, whereas for overlap exchange the receive section + ! is scattered in the owned indices, and BETA=1. + ! The first routine picks the desired exchange index list and passes it to the second. + ! + ! Arguments: + ! flag - integer Choose the algorithm for data exchange: + ! this is chosen through bit fields. + ! 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 + ! if (swap_mpi): use underlying MPI_ALLTOALLV. + ! if (swap_sync): use PSB_SND and PSB_RCV in + ! synchronized pairs + ! if (swap_send .and. swap_recv): use mpi_irecv + ! and mpi_send + ! if (swap_send): use psb_snd (but need another + ! call with swap_recv to complete) + ! if (swap_recv): use psb_rcv (completing a + ! previous call with swap_send) + ! + ! + ! n - integer Number of columns in Y + ! beta - real Choose overwrite or sum. + ! y(:) - real The data area + ! desc_a - type(psb_desc_type). The communication descriptor. + ! work(:) - real Buffer space. If not sufficient, will do + ! our own internal allocation. + ! info - integer. return code. + ! data - integer which list is to be used to exchange data + ! default psb_comm_halo_ + ! psb_comm_halo_ use halo_index + ! psb_comm_ext_ use ext_index + ! psb_comm_ovrl_ use ovrl_index + ! psb_comm_mov_ use ovr_mst_idx + ! + ! + module subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) -! -! -! Subroutine: psi_dswapdatav -! Implements the data exchange among processes. Essentially this is doing -! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! The first routine picks the desired exchange index list and passes it to the second. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! 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 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - real Choose overwrite or sum. -! y(:) - real The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - real Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_dswapdatav - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:), beta - real(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:), beta + real(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif - return -end subroutine psi_dswapdatav + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if -! -! -! Subroutine: psi_dswapdataidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_dswapidxv(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) + call psi_swapdata(ctxt,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) - use psi_mod, psb_protect_name => psi_dswapidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_dswapdatav + + + ! + ! + ! Subroutine: psi_dswapdataidxv + ! Does the data exchange among processes. + ! + ! The real workhorse: the outer routines will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_dswapidxv(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psb_error_mod + use psb_desc_mod + use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:), beta - real(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:), beta + real(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + integer(psb_mpk_) :: icomm + logical, parameter :: usersend=.false. + + real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications + ! prepare info for communications - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - end do + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - end if - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_r_dpk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_r_dpk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. end if - else if (swap_sync) then - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + if (do_send) then - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_r_dpk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_r_dpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_double_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_double_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),nerv,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_double_swap_tag - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_double_swap_tag + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_double_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),nesd,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),nesd,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,iret) + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) end if + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_double_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_dswapidxv + end subroutine psi_dswapidxv +end submodule psi_d_swapdata_a_impl diff --git a/base/comm/internals/psi_dswaptran.F90 b/base/comm/internals/psi_dswaptran.F90 index 0c168e18..ee4a1a73 100644 --- a/base/comm/internals/psi_dswaptran.F90 +++ b/base/comm/internals/psi_dswaptran.F90 @@ -91,418 +91,406 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data) +submodule (psi_d_comm_v_mod) psi_d_swaptran_impl + use psb_base_mod +contains + module subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_dswaptran_vect - use psb_d_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_d_base_vect_type) :: y - real(psb_dpk_) :: beta - real(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_vect_type) :: y + real(psb_dpk_) :: beta + real(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_dswaptran_vect + end subroutine psi_dswaptran_vect + + ! + ! + ! Subroutine: psi_dtran_vidx_vect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated vector. Relies on the gather/scatter methods + ! of vectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_dtran_vidx_vect(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_dtran_vidx_vect -! Data exchange among processes. -! -! Takes care of Y an encapsulated vector. Relies on the gather/scatter methods -! of vectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_dtran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_dtran_vidx_vect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_d_base_vect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_d_base_vect_type) :: y - real(psb_dpk_) :: beta - real(psb_dpk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - p2ptag = psb_double_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - call mpi_irecv(y%combuf(snd_pt),nesd,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - idx_pt = rcv_pt - call y%gth(idx_pt,nerv,idx) - - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - p2ptag = psb_double_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if ((nerv>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(rcv_pt),nerv,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_vect_type) :: y + real(psb_dpk_) :: beta + real(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + p2ptag = psb_double_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + call mpi_irecv(y%combuf(snd_pt),nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + idx_pt = rcv_pt + call y%gth(idx_pt,nerv,idx) + + pnti = pnti + nerv + nesd + 3 + end do - pnti = pnti + nerv + nesd + 3 - end do - end if + ! + ! Then wait + ! + call y%device_wait() - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... + if (debug) write(*,*) me,' isend' ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - p2ptag = psb_double_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (proc_to_comm /= me)then - if (nerv>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_double_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+nesd-1) + call y%sct(snd_pt,nesd,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(snd_pt:snd_pt+nesd-1) - call y%sct(snd_pt,nesd,idx,beta) - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for everybody, clean up - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return + return -end subroutine psi_dtran_vidx_vect + end subroutine psi_dtran_vidx_vect -! -! -! -! -! Subroutine: psi_dswaptran_multivect -! Data exchange among processes. -! -! Takes care of Y an encaspulated multivector. -! -! -subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data) + ! + ! + ! + ! + ! Subroutine: psi_dswaptran_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_dswaptran_multivect - use psb_d_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_d_base_multivect_type) :: y - real(psb_dpk_) :: beta - real(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: y + real(psb_dpk_) :: beta + real(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) @@ -510,273 +498,266 @@ subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data) end subroutine psi_dswaptran_multivect -! -! -! Subroutine: psi_dtran_vidx_multivect -! Data exchange among processes. -! -! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods -! of multivectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_dtran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_dtran_vidx_multivect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_d_base_multivect_mod + ! + ! + ! Subroutine: psi_dtran_vidx_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods + ! of multivectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_dtran_vidx_multivect(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_d_base_multivect_type) :: y - real(psb_dpk_) :: beta - real(psb_dpk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n = y%get_ncols() - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_d_base_multivect_type) :: y + real(psb_dpk_) :: beta + real(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + n = y%get_ncols() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt + call mpi_irecv(y%combuf(snd_pt),n*nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call y%gth(idx_pt,rcv_pt,nerv,idx) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait for device + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),n*nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_double_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt - call mpi_irecv(y%combuf(snd_pt),n*nesd,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call y%gth(idx_pt,rcv_pt,nerv,idx) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait for device - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_double_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - if ((nerv>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(rcv_pt),n*nerv,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_double_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm /= me)then - if (nerv>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_double_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(snd_pt:snd_pt+n*nesd-1) - call y%sct(idx_pt,snd_pt,nesd,idx,beta) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! - ! Waited for com, cleanup comid - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if (debug) write(*,*) me,' done' - end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+n*nesd-1) + call y%sct(idx_pt,snd_pt,nesd,idx,beta) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - call psb_erractionrestore(err_act) - return + ! + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null -9999 call psb_error_handler(ctxt,err_act) + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if - return -end subroutine psi_dtran_vidx_multivect + call psb_erractionrestore(err_act) + return +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_dtran_vidx_multivect +end submodule psi_d_swaptran_impl diff --git a/base/comm/internals/psi_dswaptran_a.F90 b/base/comm/internals/psi_dswaptran_a.F90 index dbeb5513..bd89d814 100644 --- a/base/comm/internals/psi_dswaptran_a.F90 +++ b/base/comm/internals/psi_dswaptran_a.F90 @@ -88,922 +88,909 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) +submodule (psi_d_comm_a_mod) psi_d_swaptran_a_impl + use psb_base_mod +contains + module subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_dswaptranm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, err_act, totxch, data_ - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:,:), beta + real(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, err_act, totxch, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return -end subroutine psi_dswaptranm -subroutine psi_dtranidxm(ctxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) +9999 call psb_error_handler(ctxt,err_act) - use psi_mod, psb_protect_name => psi_dtranidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_dswaptranm + + module subroutine psi_dtranidxm(ctxt,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:,:), beta + real(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + integer(psb_mpk_) :: icomm + logical, parameter :: usersend=.false. + + real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if - ! prepare info for communications + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + if (do_send) then - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd + call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 end if - albf=.true. - end if - if (do_send) then - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) + ! Case SWAP_MPI + if (swap_mpi) then - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_r_dpk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_r_dpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if - end if + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_double_swap_tag + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_double_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - ! Case SWAP_MPI - if (swap_mpi) then + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_r_dpk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_r_dpk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_double_swap_tag - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send',& + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_double_swap_tag - call mpi_irecv(sndbuf(snd_pt),n*nesd,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + else if (swap_send) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + else if (swap_recv) then - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_double_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,iret) - end if + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 + end if - end do + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_double_swap_tag + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send',& - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_dtranidxm -! -! -! Subroutine: psi_dswaptranv -! Implements the data exchange among processes. This is similar to Xswapdata, but -! the list is read "in reverse", i.e. indices that are normally SENT are used -! for the RECEIVE part and vice-versa. This is the basic data exchange operation -! for doing the product of a sparse matrix by a vector. -! Essentially this is doing a variable all-to-all data exchange -! (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! The first routine picks the desired exchange index list and passes it to the second. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! 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 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - real Choose overwrite or sum. -! y(:) - real The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - real Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_dswaptranv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + end subroutine psi_dtranidxm + ! + ! + ! Subroutine: psi_dswaptranv + ! Implements the data exchange among processes. This is similar to Xswapdata, but + ! the list is read "in reverse", i.e. indices that are normally SENT are used + ! for the RECEIVE part and vice-versa. This is the basic data exchange operation + ! for doing the product of a sparse matrix by a vector. + ! Essentially this is doing a variable all-to-all data exchange + ! (ALLTOALLV in MPI parlance), but + ! it is capable of pruning empty exchanges, which are very likely in out + ! application environment. All the variants have the same structure + ! In all these subroutines X may be: I Integer + ! S real(psb_spk_) + ! D real(psb_dpk_) + ! C complex(psb_spk_) + ! Z complex(psb_dpk_) + ! Basically the operation is as follows: on each process, we identify + ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); + ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y + ! but only on the elements involved in the UNPACK operation. + ! Thus: for halo data exchange, the receive section is confined in the + ! halo indices, and BETA=0, whereas for overlap exchange the receive section + ! is scattered in the owned indices, and BETA=1. + ! The first routine picks the desired exchange index list and passes it to the second. + ! + ! Arguments: + ! flag - integer Choose the algorithm for data exchange: + ! this is chosen through bit fields. + ! 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 + ! if (swap_mpi): use underlying MPI_ALLTOALLV. + ! if (swap_sync): use PSB_SND and PSB_RCV in + ! synchronized pairs + ! if (swap_send .and. swap_recv): use mpi_irecv + ! and mpi_send + ! if (swap_send): use psb_snd (but need another + ! call with swap_recv to complete) + ! if (swap_recv): use psb_rcv (completing a + ! previous call with swap_send) + ! + ! + ! n - integer Number of columns in Y + ! beta - real Choose overwrite or sum. + ! y(:) - real The data area + ! desc_a - type(psb_desc_type). The communication descriptor. + ! work(:) - real Buffer space. If not sufficient, will do + ! our own internal allocation. + ! info - integer. return code. + ! data - integer which list is to be used to exchange data + ! default psb_comm_halo_ + ! psb_comm_halo_ use halo_index + ! psb_comm_ext_ use ext_index + ! psb_comm_ovrl_ use ovrl_index + ! psb_comm_mov_ use ovr_mst_idx + ! + ! + module subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:), beta - real(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:), beta + real(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif - return -end subroutine psi_dswaptranv + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if -! -! -! Subroutine: psi_dtranidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_dtranidxv(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) + call psi_swaptran(ctxt,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 - use psi_mod, psb_protect_name => psi_dtranidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_dswaptranv + + + ! + ! + ! Subroutine: psi_dtranidxv + ! Does the data exchange among processes. + ! + ! The real workhorse: the outer routines will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_dtranidxv(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:), beta - real(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:), beta + real(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_mpk_) :: icomm + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications + ! prepare info for communications - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - end do + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - end if - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_r_dpk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_r_dpk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - else if (swap_sync) then + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_r_dpk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_r_dpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_double_swap_tag + call mpi_irecv(sndbuf(snd_pt),nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_double_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm < me) then + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_double_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_double_swap_tag - call mpi_irecv(sndbuf(snd_pt),nesd,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + end if - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_double_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),nerv,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag, icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),nerv,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag, icomm,iret) - end if + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_double_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_dtranidxv + end subroutine psi_dtranidxv +end submodule psi_d_swaptran_a_impl diff --git a/base/comm/internals/psi_eovrl_restr_a.f90 b/base/comm/internals/psi_eovrl_restr_a.f90 index cfd08936..2fe2b788 100644 --- a/base/comm/internals/psi_eovrl_restr_a.f90 +++ b/base/comm/internals/psi_eovrl_restr_a.f90 @@ -34,98 +34,100 @@ ! for the transpose matrix-vector product when there is a nonempty overlap. ! ! -subroutine psi_eovrl_restrr1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_eovrl_restrr1 - - implicit none - - integer(psb_epk_), intent(inout) :: x(:) - integer(psb_epk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_eovrl_restrr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return +submodule (psi_e_comm_a_mod) psi_e_ovrl_restr_a_impl + use psb_base_mod +contains + module subroutine psi_eovrl_restrr1(x,xs,desc_a,info) + + implicit none + + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_eovrl_restrr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_eovrl_restrr1 + return + end subroutine psi_eovrl_restrr1 -subroutine psi_eovrl_restrr2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_eovrl_restrr2 + module subroutine psi_eovrl_restrr2(x,xs,desc_a,info) - implicit none + implicit none - integer(psb_epk_), intent(inout) :: x(:,:) - integer(psb_epk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_epk_), intent(inout) :: x(:,:) + integer(psb_epk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err - name='psi_eovrl_restrr2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif + name='psi_eovrl_restrr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif - if (size(x,2) /= size(xs,2)) then - info = psb_err_internal_error_ - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif + if (size(x,2) /= size(xs,2)) then + info = psb_err_internal_error_ + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif - isz = size(desc_a%ovrlap_elem,1) + isz = size(desc_a%ovrlap_elem,1) - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_eovrl_restrr2 + return + end subroutine psi_eovrl_restrr2 +end submodule psi_e_ovrl_restr_a_impl diff --git a/base/comm/internals/psi_eovrl_save_a.f90 b/base/comm/internals/psi_eovrl_save_a.f90 index adcb981a..41e9e519 100644 --- a/base/comm/internals/psi_eovrl_save_a.f90 +++ b/base/comm/internals/psi_eovrl_save_a.f90 @@ -34,108 +34,104 @@ ! These subroutines save the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap. ! -subroutine psi_eovrl_saver1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_eovrl_saver1 - - use psb_realloc_mod - - implicit none - - integer(psb_epk_), intent(inout) :: x(:) - integer(psb_epk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_eovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return +submodule (psi_e_comm_a_mod) psi_e_ovrl_save_a_impl + use psb_base_mod +contains + module subroutine psi_eovrl_saver1(x,xs,desc_a,info) + implicit none + + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_eovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_eovrl_saver1 - - -subroutine psi_eovrl_saver2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_eovrl_saver2 - - use psb_realloc_mod - - implicit none - - integer(psb_epk_), intent(inout) :: x(:,:) - integer(psb_epk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_eovrl_saver2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_eovrl_saver1 + + + module subroutine psi_eovrl_saver2(x,xs,desc_a,info) + implicit none + + integer(psb_epk_), intent(inout) :: x(:,:) + integer(psb_epk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_eovrl_saver2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_eovrl_saver2 + return + end subroutine psi_eovrl_saver2 +end submodule psi_e_ovrl_save_a_impl diff --git a/base/comm/internals/psi_eovrl_upd_a.f90 b/base/comm/internals/psi_eovrl_upd_a.f90 index c1427547..0b6e6f9d 100644 --- a/base/comm/internals/psi_eovrl_upd_a.f90 +++ b/base/comm/internals/psi_eovrl_upd_a.f90 @@ -32,143 +32,143 @@ ! Subroutine: psi_eovrl_update ! These subroutines update the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap, -! or for the application of Additive Schwarz preconditioners. +! or for the application of Additive Schwarz preconditioners. ! ! -subroutine psi_eovrl_updr1(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_eovrl_updr1 - - implicit none - - integer(psb_epk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_eovrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = ezero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return +submodule (psi_e_comm_a_mod) psi_e_ovrl_upd_a_impl + use psb_base_mod +contains + module subroutine psi_eovrl_updr1(x,desc_a,update,info) + implicit none + + integer(psb_epk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_eovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = ezero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_eovrl_updr1 - -subroutine psi_eovrl_updr2(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_eovrl_updr2 - - implicit none - - integer(psb_epk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_eovrl_updr2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = ezero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_eovrl_updr1 + + module subroutine psi_eovrl_updr2(x,desc_a,update,info) + implicit none + + integer(psb_epk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_eovrl_updr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = ezero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_eovrl_updr2 + return + end subroutine psi_eovrl_updr2 +end submodule psi_e_ovrl_upd_a_impl diff --git a/base/comm/internals/psi_eswapdata_a.F90 b/base/comm/internals/psi_eswapdata_a.F90 index 8a7afe67..5285b464 100644 --- a/base/comm/internals/psi_eswapdata_a.F90 +++ b/base/comm/internals/psi_eswapdata_a.F90 @@ -84,912 +84,899 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_eswapdatam(flag,n,beta,y,desc_a,work,info,data) +submodule (psi_e_comm_a_mod) psi_e_swapdata_a_impl + use psb_base_mod +contains + module subroutine psi_eswapdatam(flag,n,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_eswapdatam - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_epk_) :: y(:,:), beta - integer(psb_epk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info +integer(psb_epk_) :: y(:,:), beta +integer(psb_epk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_eswapdatam + end subroutine psi_eswapdatam -subroutine psi_eswapidxm(ctxt,icomm,flag,n,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) + module subroutine psi_eswapidxm(ctxt,flag,n,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) - use psi_mod, psb_protect_name => psi_eswapidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_epk_) :: y(:,:), beta - integer(psb_epk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - - integer(psb_mpk_) :: np, me, nesd, nerv - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info +integer(psb_epk_) :: y(:,:), beta +integer(psb_epk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + + integer(psb_mpk_) :: np, me, nesd, nerv + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_mpk_) :: icomm + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + +integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if - ! prepare info for communications + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + end if - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_epk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_epk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int8_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_epk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_epk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_epk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int8_swap_tag + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & psb_mpi_epk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & psb_mpi_epk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int8_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*)& + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_sync) then - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + else if (swap_send) then - if (proc_to_comm < me) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - end do + end if + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then + end if - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int8_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_epk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_int8_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),n*nesd,& - & psb_mpi_epk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),n*nesd,& - & psb_mpi_epk_,prcid(i),& - & p2ptag,icomm,iret) - end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_int8_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*)& - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_eswapidxm + end subroutine psi_eswapidxm + + ! + ! + ! Subroutine: psi_eswapdatav + ! Implements the data exchange among processes. Essentially this is doing + ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but + ! it is capable of pruning empty exchanges, which are very likely in out + ! application environment. All the variants have the same structure + ! In all these subroutines X may be: I Integer + ! S real(psb_spk_) + ! D real(psb_dpk_) + ! C complex(psb_spk_) + ! Z complex(psb_dpk_) + ! Basically the operation is as follows: on each process, we identify + ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); + ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y + ! but only on the elements involved in the UNPACK operation. + ! Thus: for halo data exchange, the receive section is confined in the + ! halo indices, and BETA=0, whereas for overlap exchange the receive section + ! is scattered in the owned indices, and BETA=1. + ! The first routine picks the desired exchange index list and passes it to the second. + ! + ! Arguments: + ! flag - integer Choose the algorithm for data exchange: + ! this is chosen through bit fields. + ! 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 + ! if (swap_mpi): use underlying MPI_ALLTOALLV. + ! if (swap_sync): use PSB_SND and PSB_RCV in + ! synchronized pairs + ! if (swap_send .and. swap_recv): use mpi_irecv + ! and mpi_send + ! if (swap_send): use psb_snd (but need another + ! call with swap_recv to complete) + ! if (swap_recv): use psb_rcv (completing a + ! previous call with swap_send) + ! + ! + ! n - integer Number of columns in Y + ! beta - integer Choose overwrite or sum. + ! y(:) - integer The data area + ! desc_a - type(psb_desc_type). The communication descriptor. + ! work(:) - integer Buffer space. If not sufficient, will do + ! our own internal allocation. + ! info - integer. return code. + ! data - integer which list is to be used to exchange data + ! default psb_comm_halo_ + ! psb_comm_halo_ use halo_index + ! psb_comm_ext_ use ext_index + ! psb_comm_ovrl_ use ovrl_index + ! psb_comm_mov_ use ovr_mst_idx + ! + ! + module subroutine psi_eswapdatav(flag,beta,y,desc_a,work,info,data) -! -! -! Subroutine: psi_eswapdatav -! Implements the data exchange among processes. Essentially this is doing -! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! The first routine picks the desired exchange index list and passes it to the second. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! 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 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - integer Choose overwrite or sum. -! y(:) - integer The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - integer Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_eswapdatav(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_eswapdatav - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_epk_) :: y(:), beta - integer(psb_epk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:), beta + integer(psb_epk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif - return -end subroutine psi_eswapdatav + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if -! -! -! Subroutine: psi_eswapdataidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_eswapidxv(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) + call psi_swapdata(ctxt,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) - use psi_mod, psb_protect_name => psi_eswapidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_eswapdatav + + + ! + ! + ! Subroutine: psi_eswapdataidxv + ! Does the data exchange among processes. + ! + ! The real workhorse: the outer routines will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_eswapidxv(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psb_error_mod + use psb_desc_mod + use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_epk_) :: y(:), beta - integer(psb_epk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:), beta + integer(psb_epk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + integer(psb_mpk_) :: icomm + logical, parameter :: usersend=.false. + + integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications + ! prepare info for communications - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - end do + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - end if - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_epk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_epk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. end if - else if (swap_sync) then - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + if (do_send) then - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_epk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_epk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int8_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & psb_mpi_epk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int8_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),nerv,& - & psb_mpi_epk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int8_swap_tag - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & psb_mpi_epk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & psb_mpi_epk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int8_swap_tag + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int8_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),nesd,& - & psb_mpi_epk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),nesd,& - & psb_mpi_epk_,prcid(i),& - & p2ptag,icomm,iret) + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) end if + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int8_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_eswapidxv + end subroutine psi_eswapidxv +end submodule psi_e_swapdata_a_impl diff --git a/base/comm/internals/psi_eswaptran_a.F90 b/base/comm/internals/psi_eswaptran_a.F90 index f5817419..b5f375ff 100644 --- a/base/comm/internals/psi_eswaptran_a.F90 +++ b/base/comm/internals/psi_eswaptran_a.F90 @@ -88,922 +88,909 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_eswaptranm(flag,n,beta,y,desc_a,work,info,data) +submodule (psi_e_comm_a_mod) psi_e_swaptran_a_impl + use psb_base_mod +contains + module subroutine psi_eswaptranm(flag,n,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_eswaptranm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_epk_) :: y(:,:), beta - integer(psb_epk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, err_act, totxch, data_ - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:,:), beta + integer(psb_epk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, err_act, totxch, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return -end subroutine psi_eswaptranm -subroutine psi_etranidxm(ctxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) +9999 call psb_error_handler(ctxt,err_act) - use psi_mod, psb_protect_name => psi_etranidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_eswaptranm + + module subroutine psi_etranidxm(ctxt,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_epk_) :: y(:,:), beta - integer(psb_epk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:,:), beta + integer(psb_epk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + integer(psb_mpk_) :: icomm + logical, parameter :: usersend=.false. + + integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if - ! prepare info for communications + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + if (do_send) then - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd + call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 end if - albf=.true. - end if - if (do_send) then - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) + ! Case SWAP_MPI + if (swap_mpi) then - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_epk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_epk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if - end if + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int8_swap_tag + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & psb_mpi_epk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int8_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_epk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_epk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - ! Case SWAP_MPI - if (swap_mpi) then + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_epk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_epk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int8_swap_tag - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send',& + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int8_swap_tag - call mpi_irecv(sndbuf(snd_pt),n*nesd,& - & psb_mpi_epk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + else if (swap_send) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + else if (swap_recv) then - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int8_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_epk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_epk_,prcid(i),& - & p2ptag,icomm,iret) - end if + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 + end if - end do + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int8_swap_tag + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send',& - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_etranidxm -! -! -! Subroutine: psi_eswaptranv -! Implements the data exchange among processes. This is similar to Xswapdata, but -! the list is read "in reverse", i.e. indices that are normally SENT are used -! for the RECEIVE part and vice-versa. This is the basic data exchange operation -! for doing the product of a sparse matrix by a vector. -! Essentially this is doing a variable all-to-all data exchange -! (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! The first routine picks the desired exchange index list and passes it to the second. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! 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 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - integer Choose overwrite or sum. -! y(:) - integer The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - integer Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_eswaptranv(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_eswaptranv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + end subroutine psi_etranidxm + ! + ! + ! Subroutine: psi_eswaptranv + ! Implements the data exchange among processes. This is similar to Xswapdata, but + ! the list is read "in reverse", i.e. indices that are normally SENT are used + ! for the RECEIVE part and vice-versa. This is the basic data exchange operation + ! for doing the product of a sparse matrix by a vector. + ! Essentially this is doing a variable all-to-all data exchange + ! (ALLTOALLV in MPI parlance), but + ! it is capable of pruning empty exchanges, which are very likely in out + ! application environment. All the variants have the same structure + ! In all these subroutines X may be: I Integer + ! S real(psb_spk_) + ! D real(psb_dpk_) + ! C complex(psb_spk_) + ! Z complex(psb_dpk_) + ! Basically the operation is as follows: on each process, we identify + ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); + ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y + ! but only on the elements involved in the UNPACK operation. + ! Thus: for halo data exchange, the receive section is confined in the + ! halo indices, and BETA=0, whereas for overlap exchange the receive section + ! is scattered in the owned indices, and BETA=1. + ! The first routine picks the desired exchange index list and passes it to the second. + ! + ! Arguments: + ! flag - integer Choose the algorithm for data exchange: + ! this is chosen through bit fields. + ! 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 + ! if (swap_mpi): use underlying MPI_ALLTOALLV. + ! if (swap_sync): use PSB_SND and PSB_RCV in + ! synchronized pairs + ! if (swap_send .and. swap_recv): use mpi_irecv + ! and mpi_send + ! if (swap_send): use psb_snd (but need another + ! call with swap_recv to complete) + ! if (swap_recv): use psb_rcv (completing a + ! previous call with swap_send) + ! + ! + ! n - integer Number of columns in Y + ! beta - integer Choose overwrite or sum. + ! y(:) - integer The data area + ! desc_a - type(psb_desc_type). The communication descriptor. + ! work(:) - integer Buffer space. If not sufficient, will do + ! our own internal allocation. + ! info - integer. return code. + ! data - integer which list is to be used to exchange data + ! default psb_comm_halo_ + ! psb_comm_halo_ use halo_index + ! psb_comm_ext_ use ext_index + ! psb_comm_ovrl_ use ovrl_index + ! psb_comm_mov_ use ovr_mst_idx + ! + ! + module subroutine psi_eswaptranv(flag,beta,y,desc_a,work,info,data) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_epk_) :: y(:), beta - integer(psb_epk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:), beta + integer(psb_epk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif - return -end subroutine psi_eswaptranv + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if -! -! -! Subroutine: psi_etranidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_etranidxv(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) + call psi_swaptran(ctxt,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 - use psi_mod, psb_protect_name => psi_etranidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_eswaptranv + + + ! + ! + ! Subroutine: psi_etranidxv + ! Does the data exchange among processes. + ! + ! The real workhorse: the outer routines will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_etranidxv(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_epk_) :: y(:), beta - integer(psb_epk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:), beta + integer(psb_epk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_mpk_) :: icomm + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications + ! prepare info for communications - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - end do + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - end if - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_epk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_epk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - else if (swap_sync) then + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_epk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_epk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int8_swap_tag + call mpi_irecv(sndbuf(snd_pt),nesd,& + & psb_mpi_epk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int8_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & psb_mpi_epk_,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & psb_mpi_epk_,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm < me) then + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int8_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int8_swap_tag - call mpi_irecv(sndbuf(snd_pt),nesd,& - & psb_mpi_epk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + end if - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int8_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),nerv,& - & psb_mpi_epk_,prcid(i),& - & p2ptag, icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),nerv,& - & psb_mpi_epk_,prcid(i),& - & p2ptag, icomm,iret) - end if + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int8_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_etranidxv + end subroutine psi_etranidxv +end submodule psi_e_swaptran_a_impl diff --git a/base/comm/internals/psi_i2ovrl_restr_a.f90 b/base/comm/internals/psi_i2ovrl_restr_a.f90 index acb6b25d..49cf864d 100644 --- a/base/comm/internals/psi_i2ovrl_restr_a.f90 +++ b/base/comm/internals/psi_i2ovrl_restr_a.f90 @@ -34,98 +34,100 @@ ! for the transpose matrix-vector product when there is a nonempty overlap. ! ! -subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_i2ovrl_restrr1 - - implicit none - - integer(psb_i2pk_), intent(inout) :: x(:) - integer(psb_i2pk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_i2ovrl_restrr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return +submodule (psi_i2_comm_a_mod) psi_i2_ovrl_restr_a_impl + use psb_base_mod +contains + module subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info) + + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_i2pk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_i2ovrl_restrr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_i2ovrl_restrr1 + return + end subroutine psi_i2ovrl_restrr1 -subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_i2ovrl_restrr2 + module subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info) - implicit none + implicit none - integer(psb_i2pk_), intent(inout) :: x(:,:) - integer(psb_i2pk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_), intent(inout) :: x(:,:) + integer(psb_i2pk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err - name='psi_i2ovrl_restrr2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif + name='psi_i2ovrl_restrr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif - if (size(x,2) /= size(xs,2)) then - info = psb_err_internal_error_ - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif + if (size(x,2) /= size(xs,2)) then + info = psb_err_internal_error_ + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif - isz = size(desc_a%ovrlap_elem,1) + isz = size(desc_a%ovrlap_elem,1) - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_i2ovrl_restrr2 + return + end subroutine psi_i2ovrl_restrr2 +end submodule psi_i2_ovrl_restr_a_impl diff --git a/base/comm/internals/psi_i2ovrl_save_a.f90 b/base/comm/internals/psi_i2ovrl_save_a.f90 index dc0b3f54..09c0cd19 100644 --- a/base/comm/internals/psi_i2ovrl_save_a.f90 +++ b/base/comm/internals/psi_i2ovrl_save_a.f90 @@ -34,108 +34,104 @@ ! These subroutines save the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap. ! -subroutine psi_i2ovrl_saver1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_i2ovrl_saver1 - - use psb_realloc_mod - - implicit none - - integer(psb_i2pk_), intent(inout) :: x(:) - integer(psb_i2pk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_i2ovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return +submodule (psi_i2_comm_a_mod) psi_i2_ovrl_save_a_impl + use psb_base_mod +contains + module subroutine psi_i2ovrl_saver1(x,xs,desc_a,info) + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:) + integer(psb_i2pk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_i2ovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_i2ovrl_saver1 - - -subroutine psi_i2ovrl_saver2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_i2ovrl_saver2 - - use psb_realloc_mod - - implicit none - - integer(psb_i2pk_), intent(inout) :: x(:,:) - integer(psb_i2pk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_i2ovrl_saver2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_i2ovrl_saver1 + + + module subroutine psi_i2ovrl_saver2(x,xs,desc_a,info) + implicit none + + integer(psb_i2pk_), intent(inout) :: x(:,:) + integer(psb_i2pk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_i2ovrl_saver2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_i2ovrl_saver2 + return + end subroutine psi_i2ovrl_saver2 +end submodule psi_i2_ovrl_save_a_impl diff --git a/base/comm/internals/psi_i2ovrl_upd_a.f90 b/base/comm/internals/psi_i2ovrl_upd_a.f90 index 973ffa8e..82d52fdf 100644 --- a/base/comm/internals/psi_i2ovrl_upd_a.f90 +++ b/base/comm/internals/psi_i2ovrl_upd_a.f90 @@ -32,143 +32,143 @@ ! Subroutine: psi_i2ovrl_update ! These subroutines update the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap, -! or for the application of Additive Schwarz preconditioners. +! or for the application of Additive Schwarz preconditioners. ! ! -subroutine psi_i2ovrl_updr1(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_i2ovrl_updr1 - - implicit none - - integer(psb_i2pk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_i2ovrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = i2zero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return +submodule (psi_i2_comm_a_mod) psi_i2_ovrl_upd_a_impl + use psb_base_mod +contains + module subroutine psi_i2ovrl_updr1(x,desc_a,update,info) + implicit none + + integer(psb_i2pk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_i2ovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = i2zero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_i2ovrl_updr1 - -subroutine psi_i2ovrl_updr2(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_i2ovrl_updr2 - - implicit none - - integer(psb_i2pk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_i2ovrl_updr2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = i2zero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_i2ovrl_updr1 + + module subroutine psi_i2ovrl_updr2(x,desc_a,update,info) + implicit none + + integer(psb_i2pk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_i2ovrl_updr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = i2zero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_i2ovrl_updr2 + return + end subroutine psi_i2ovrl_updr2 +end submodule psi_i2_ovrl_upd_a_impl diff --git a/base/comm/internals/psi_i2swapdata_a.F90 b/base/comm/internals/psi_i2swapdata_a.F90 index b7d8b8f5..cb368d54 100644 --- a/base/comm/internals/psi_i2swapdata_a.F90 +++ b/base/comm/internals/psi_i2swapdata_a.F90 @@ -84,912 +84,899 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_i2swapdatam(flag,n,beta,y,desc_a,work,info,data) +submodule (psi_i2_comm_a_mod) psi_i2_swapdata_a_impl + use psb_base_mod +contains + module subroutine psi_i2swapdatam(flag,n,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_i2swapdatam - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_i2pk_) :: y(:,:), beta - integer(psb_i2pk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info +integer(psb_i2pk_) :: y(:,:), beta +integer(psb_i2pk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_i2swapdatam + end subroutine psi_i2swapdatam -subroutine psi_i2swapidxm(ctxt,icomm,flag,n,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) + module subroutine psi_i2swapidxm(ctxt,flag,n,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) - use psi_mod, psb_protect_name => psi_i2swapidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_i2pk_) :: y(:,:), beta - integer(psb_i2pk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - - integer(psb_mpk_) :: np, me, nesd, nerv - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info +integer(psb_i2pk_) :: y(:,:), beta +integer(psb_i2pk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + + integer(psb_mpk_) :: np, me, nesd, nerv + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_mpk_) :: icomm + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + +integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if - ! prepare info for communications + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + end if - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_i2pk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_i2pk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int2_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_i2pk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_i2pk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int2_swap_tag + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int2_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*)& + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_sync) then - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + else if (swap_send) then - if (proc_to_comm < me) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - end do + end if + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then + end if - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int2_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_i2pk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_int2_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),n*nesd,& - & psb_mpi_i2pk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),n*nesd,& - & psb_mpi_i2pk_,prcid(i),& - & p2ptag,icomm,iret) - end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_int2_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*)& - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_i2swapidxm + end subroutine psi_i2swapidxm + + ! + ! + ! Subroutine: psi_i2swapdatav + ! Implements the data exchange among processes. Essentially this is doing + ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but + ! it is capable of pruning empty exchanges, which are very likely in out + ! application environment. All the variants have the same structure + ! In all these subroutines X may be: I Integer + ! S real(psb_spk_) + ! D real(psb_dpk_) + ! C complex(psb_spk_) + ! Z complex(psb_dpk_) + ! Basically the operation is as follows: on each process, we identify + ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); + ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y + ! but only on the elements involved in the UNPACK operation. + ! Thus: for halo data exchange, the receive section is confined in the + ! halo indices, and BETA=0, whereas for overlap exchange the receive section + ! is scattered in the owned indices, and BETA=1. + ! The first routine picks the desired exchange index list and passes it to the second. + ! + ! Arguments: + ! flag - integer Choose the algorithm for data exchange: + ! this is chosen through bit fields. + ! 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 + ! if (swap_mpi): use underlying MPI_ALLTOALLV. + ! if (swap_sync): use PSB_SND and PSB_RCV in + ! synchronized pairs + ! if (swap_send .and. swap_recv): use mpi_irecv + ! and mpi_send + ! if (swap_send): use psb_snd (but need another + ! call with swap_recv to complete) + ! if (swap_recv): use psb_rcv (completing a + ! previous call with swap_send) + ! + ! + ! n - integer Number of columns in Y + ! beta - integer Choose overwrite or sum. + ! y(:) - integer The data area + ! desc_a - type(psb_desc_type). The communication descriptor. + ! work(:) - integer Buffer space. If not sufficient, will do + ! our own internal allocation. + ! info - integer. return code. + ! data - integer which list is to be used to exchange data + ! default psb_comm_halo_ + ! psb_comm_halo_ use halo_index + ! psb_comm_ext_ use ext_index + ! psb_comm_ovrl_ use ovrl_index + ! psb_comm_mov_ use ovr_mst_idx + ! + ! + module subroutine psi_i2swapdatav(flag,beta,y,desc_a,work,info,data) -! -! -! Subroutine: psi_i2swapdatav -! Implements the data exchange among processes. Essentially this is doing -! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! The first routine picks the desired exchange index list and passes it to the second. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! 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 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - integer Choose overwrite or sum. -! y(:) - integer The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - integer Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_i2swapdatav(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_i2swapdatav - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_i2pk_) :: y(:), beta - integer(psb_i2pk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:), beta + integer(psb_i2pk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif - return -end subroutine psi_i2swapdatav + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if -! -! -! Subroutine: psi_i2swapdataidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_i2swapidxv(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) + call psi_swapdata(ctxt,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) - use psi_mod, psb_protect_name => psi_i2swapidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_i2swapdatav + + + ! + ! + ! Subroutine: psi_i2swapdataidxv + ! Does the data exchange among processes. + ! + ! The real workhorse: the outer routines will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_i2swapidxv(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psb_error_mod + use psb_desc_mod + use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_i2pk_) :: y(:), beta - integer(psb_i2pk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:), beta + integer(psb_i2pk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + integer(psb_mpk_) :: icomm + logical, parameter :: usersend=.false. + + integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications + ! prepare info for communications - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - end do + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - end if - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_i2pk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_i2pk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. end if - else if (swap_sync) then - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + if (do_send) then - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_i2pk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_i2pk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int2_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int2_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),nerv,& - & psb_mpi_i2pk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int2_swap_tag - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int2_swap_tag + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int2_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),nesd,& - & psb_mpi_i2pk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),nesd,& - & psb_mpi_i2pk_,prcid(i),& - & p2ptag,icomm,iret) + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) end if + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int2_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_i2swapidxv + end subroutine psi_i2swapidxv +end submodule psi_i2_swapdata_a_impl diff --git a/base/comm/internals/psi_i2swaptran_a.F90 b/base/comm/internals/psi_i2swaptran_a.F90 index d43112c4..3244dd66 100644 --- a/base/comm/internals/psi_i2swaptran_a.F90 +++ b/base/comm/internals/psi_i2swaptran_a.F90 @@ -88,922 +88,909 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_i2swaptranm(flag,n,beta,y,desc_a,work,info,data) +submodule (psi_i2_comm_a_mod) psi_i2_swaptran_a_impl + use psb_base_mod +contains + module subroutine psi_i2swaptranm(flag,n,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_i2swaptranm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_i2pk_) :: y(:,:), beta - integer(psb_i2pk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, err_act, totxch, data_ - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:,:), beta + integer(psb_i2pk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, err_act, totxch, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return -end subroutine psi_i2swaptranm -subroutine psi_i2tranidxm(ctxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) +9999 call psb_error_handler(ctxt,err_act) - use psi_mod, psb_protect_name => psi_i2tranidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_i2swaptranm + + module subroutine psi_i2tranidxm(ctxt,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_i2pk_) :: y(:,:), beta - integer(psb_i2pk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:,:), beta + integer(psb_i2pk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + integer(psb_mpk_) :: icomm + logical, parameter :: usersend=.false. + + integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if - ! prepare info for communications + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + if (do_send) then - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd + call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 end if - albf=.true. - end if - if (do_send) then - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) + ! Case SWAP_MPI + if (swap_mpi) then - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_i2pk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_i2pk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if - end if + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int2_swap_tag + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int2_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - ! Case SWAP_MPI - if (swap_mpi) then + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_i2pk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_i2pk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int2_swap_tag - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send',& + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int2_swap_tag - call mpi_irecv(sndbuf(snd_pt),n*nesd,& - & psb_mpi_i2pk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + else if (swap_send) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + else if (swap_recv) then - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int2_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_i2pk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_i2pk_,prcid(i),& - & p2ptag,icomm,iret) - end if + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 + end if - end do + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int2_swap_tag + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send',& - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_i2tranidxm -! -! -! Subroutine: psi_i2swaptranv -! Implements the data exchange among processes. This is similar to Xswapdata, but -! the list is read "in reverse", i.e. indices that are normally SENT are used -! for the RECEIVE part and vice-versa. This is the basic data exchange operation -! for doing the product of a sparse matrix by a vector. -! Essentially this is doing a variable all-to-all data exchange -! (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! The first routine picks the desired exchange index list and passes it to the second. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! 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 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - integer Choose overwrite or sum. -! y(:) - integer The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - integer Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_i2swaptranv(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_i2swaptranv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + end subroutine psi_i2tranidxm + ! + ! + ! Subroutine: psi_i2swaptranv + ! Implements the data exchange among processes. This is similar to Xswapdata, but + ! the list is read "in reverse", i.e. indices that are normally SENT are used + ! for the RECEIVE part and vice-versa. This is the basic data exchange operation + ! for doing the product of a sparse matrix by a vector. + ! Essentially this is doing a variable all-to-all data exchange + ! (ALLTOALLV in MPI parlance), but + ! it is capable of pruning empty exchanges, which are very likely in out + ! application environment. All the variants have the same structure + ! In all these subroutines X may be: I Integer + ! S real(psb_spk_) + ! D real(psb_dpk_) + ! C complex(psb_spk_) + ! Z complex(psb_dpk_) + ! Basically the operation is as follows: on each process, we identify + ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); + ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y + ! but only on the elements involved in the UNPACK operation. + ! Thus: for halo data exchange, the receive section is confined in the + ! halo indices, and BETA=0, whereas for overlap exchange the receive section + ! is scattered in the owned indices, and BETA=1. + ! The first routine picks the desired exchange index list and passes it to the second. + ! + ! Arguments: + ! flag - integer Choose the algorithm for data exchange: + ! this is chosen through bit fields. + ! 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 + ! if (swap_mpi): use underlying MPI_ALLTOALLV. + ! if (swap_sync): use PSB_SND and PSB_RCV in + ! synchronized pairs + ! if (swap_send .and. swap_recv): use mpi_irecv + ! and mpi_send + ! if (swap_send): use psb_snd (but need another + ! call with swap_recv to complete) + ! if (swap_recv): use psb_rcv (completing a + ! previous call with swap_send) + ! + ! + ! n - integer Number of columns in Y + ! beta - integer Choose overwrite or sum. + ! y(:) - integer The data area + ! desc_a - type(psb_desc_type). The communication descriptor. + ! work(:) - integer Buffer space. If not sufficient, will do + ! our own internal allocation. + ! info - integer. return code. + ! data - integer which list is to be used to exchange data + ! default psb_comm_halo_ + ! psb_comm_halo_ use halo_index + ! psb_comm_ext_ use ext_index + ! psb_comm_ovrl_ use ovrl_index + ! psb_comm_mov_ use ovr_mst_idx + ! + ! + module subroutine psi_i2swaptranv(flag,beta,y,desc_a,work,info,data) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_i2pk_) :: y(:), beta - integer(psb_i2pk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:), beta + integer(psb_i2pk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif - return -end subroutine psi_i2swaptranv + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if -! -! -! Subroutine: psi_i2tranidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_i2tranidxv(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) + call psi_swaptran(ctxt,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 - use psi_mod, psb_protect_name => psi_i2tranidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_i2swaptranv + + + ! + ! + ! Subroutine: psi_i2tranidxv + ! Does the data exchange among processes. + ! + ! The real workhorse: the outer routines will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_i2tranidxv(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_i2pk_) :: y(:), beta - integer(psb_i2pk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_i2pk_) :: y(:), beta + integer(psb_i2pk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_mpk_) :: icomm + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + integer(psb_i2pk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications + ! prepare info for communications - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - end do + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - end if - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_i2pk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_i2pk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - else if (swap_sync) then + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_i2pk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_i2pk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int2_swap_tag + call mpi_irecv(sndbuf(snd_pt),nesd,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int2_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & psb_mpi_i2pk_,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm < me) then + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int2_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int2_swap_tag - call mpi_irecv(sndbuf(snd_pt),nesd,& - & psb_mpi_i2pk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + end if - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int2_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),nerv,& - & psb_mpi_i2pk_,prcid(i),& - & p2ptag, icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),nerv,& - & psb_mpi_i2pk_,prcid(i),& - & p2ptag, icomm,iret) - end if + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int2_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_i2tranidxv + end subroutine psi_i2tranidxv +end submodule psi_i2_swaptran_a_impl diff --git a/base/comm/internals/psi_iovrl_restr.f90 b/base/comm/internals/psi_iovrl_restr.f90 index 599a986e..838b7e50 100644 --- a/base/comm/internals/psi_iovrl_restr.f90 +++ b/base/comm/internals/psi_iovrl_restr.f90 @@ -35,90 +35,90 @@ ! ! ! -subroutine psi_iovrl_restr_vect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_iovrl_restr_vect - use psb_i_base_vect_mod - - implicit none - - class(psb_i_base_vect_type) :: x - integer(psb_ipk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_iovrl_restr_vect' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,izero) - - call psb_erractionrestore(err_act) - return +submodule (psi_i_comm_v_mod) psi_i_ovrl_restr_v_impl + use psb_base_mod +contains + module subroutine psi_iovrl_restr_vect(x,xs,desc_a,info) + + implicit none + + class(psb_i_base_vect_type) :: x + integer(psb_ipk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_iovrl_restr_vect' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,izero) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_iovrl_restr_vect + return + end subroutine psi_iovrl_restr_vect -subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_iovrl_restr_multivect - use psb_i_base_vect_mod + module subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info) - implicit none + implicit none - class(psb_i_base_multivect_type) :: x - integer(psb_ipk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: x + integer(psb_ipk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz,nc - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz,nc + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err - name='psi_iovrl_restr_mv' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif + name='psi_iovrl_restr_mv' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif - isz = size(desc_a%ovrlap_elem,1) - call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,izero) + isz = size(desc_a%ovrlap_elem,1) + call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,izero) - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_iovrl_restr_multivect + return + end subroutine psi_iovrl_restr_multivect +end submodule psi_i_ovrl_restr_v_impl diff --git a/base/comm/internals/psi_iovrl_save.f90 b/base/comm/internals/psi_iovrl_save.f90 index eb7a7ffb..ed84f7b1 100644 --- a/base/comm/internals/psi_iovrl_save.f90 +++ b/base/comm/internals/psi_iovrl_save.f90 @@ -34,103 +34,101 @@ ! for the transpose matrix-vector product when there is a nonempty overlap. ! ! -subroutine psi_iovrl_save_vect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_iovrl_save_vect - use psb_realloc_mod - use psb_i_base_vect_mod - - implicit none - - class(psb_i_base_vect_type) :: x - integer(psb_ipk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_dovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) - - call psb_erractionrestore(err_act) - return +submodule (psi_i_comm_v_mod) psi_i_ovrl_save_v_impl + use psb_base_mod +contains + module subroutine psi_iovrl_save_vect(x,xs,desc_a,info) + + implicit none + + class(psb_i_base_vect_type) :: x + integer(psb_ipk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_iovrl_save_vect - -subroutine psi_iovrl_save_multivect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_iovrl_save_multivect - use psb_realloc_mod - use psb_i_base_vect_mod - - implicit none - - class(psb_i_base_multivect_type) :: x - integer(psb_ipk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, nc - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_dovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = x%get_ncols() - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_iovrl_save_vect + + module subroutine psi_iovrl_save_multivect(x,xs,desc_a,info) + + implicit none + + class(psb_i_base_multivect_type) :: x + integer(psb_ipk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, nc + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_iovrl_save_multivect + return + end subroutine psi_iovrl_save_multivect +end submodule psi_i_ovrl_save_v_impl diff --git a/base/comm/internals/psi_iovrl_upd.f90 b/base/comm/internals/psi_iovrl_upd.f90 index cf3c201b..6873e3d3 100644 --- a/base/comm/internals/psi_iovrl_upd.f90 +++ b/base/comm/internals/psi_iovrl_upd.f90 @@ -36,169 +36,167 @@ ! ! ! -subroutine psi_iovrl_upd_vect(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_iovrl_upd_vect - use psb_realloc_mod - use psb_i_base_vect_mod - - implicit none - - class(psb_i_base_vect_type) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_), allocatable :: xs(:) - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, nx, ndm - integer(psb_ipk_) :: err_act, i, idx - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - - name='psi_iovrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - nx = size(desc_a%ovrlap_elem,1) - call psb_realloc(nx,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_Dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - if (update /= psb_sum_) then - call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) - ! switch on update type - - select case (update) - case(psb_square_root_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i) = xs(i)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i) = xs(i)/real(ndm) - end do - case(psb_setzero_) - do i=1,nx - if (me /= desc_a%ovrlap_elem(i,3))& - & xs(i) = izero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) +submodule (psi_i_comm_v_mod) psi_i_ovrl_upd_v_impl + use psb_base_mod +contains + module subroutine psi_iovrl_upd_vect(x,desc_a,update,info) + + implicit none + + class(psb_i_base_vect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_), allocatable :: xs(:) + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, nx, ndm + integer(psb_ipk_) :: err_act, i, idx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_iovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end select - call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,izero) - end if - - call psb_erractionrestore(err_act) - return + endif + nx = size(desc_a%ovrlap_elem,1) + call psb_realloc(nx,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i) = izero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,izero) + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_iovrl_upd_vect - -subroutine psi_iovrl_upd_multivect(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_iovrl_upd_multivect - use psb_realloc_mod - use psb_i_base_vect_mod - - implicit none - - class(psb_i_base_multivect_type) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_), allocatable :: xs(:,:) - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, ndm, nx, nc - integer(psb_ipk_) :: err_act, i, idx - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - - name='psi_iovrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - nx = size(desc_a%ovrlap_elem,1) - nc = x%get_ncols() - call psb_realloc(nx,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_Dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - if (update /= psb_sum_) then - call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) - ! switch on update type - - select case (update) - case(psb_square_root_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i,:) = xs(i,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i,:) = xs(i,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,nx - if (me /= desc_a%ovrlap_elem(i,3))& - & xs(i,:) = izero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) + return + end subroutine psi_iovrl_upd_vect + + module subroutine psi_iovrl_upd_multivect(x,desc_a,update,info) + + implicit none + + class(psb_i_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_), allocatable :: xs(:,:) + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, ndm, nx, nc + integer(psb_ipk_) :: err_act, i, idx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_iovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end select - call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,izero) - end if - - call psb_erractionrestore(err_act) - return + endif + nx = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(nx,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i,:) = izero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,izero) + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_iovrl_upd_multivect + return + end subroutine psi_iovrl_upd_multivect +end submodule psi_i_ovrl_upd_v_impl diff --git a/base/comm/internals/psi_iswapdata.F90 b/base/comm/internals/psi_iswapdata.F90 index fc4ee262..23c6d1da 100644 --- a/base/comm/internals/psi_iswapdata.F90 +++ b/base/comm/internals/psi_iswapdata.F90 @@ -89,676 +89,659 @@ ! ! ! -subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data) +submodule (psi_i_comm_v_mod) psi_i_swapdata_impl + use psb_base_mod +contains + subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_iswapdata_vect - use psb_i_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_vect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_), target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) return -end subroutine psi_iswapdata_vect +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_iswapdata_vect + + + ! + ! + ! Subroutine: psi_iswap_vidx_vect + ! Data exchange among processes. + ! + ! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods + ! of vectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_iswap_vidx_vect(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_iswap_vidx_vect -! Data exchange among processes. -! -! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods -! of vectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_iswap_vidx_vect(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_iswap_vidx_vect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_i_base_vect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_vect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, nesd, nerv - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, n - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),& + & iret, nesd, nerv + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + rcv_pt = 1+pnti+psb_n_elem_recv_ + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_int_swap_tag + call mpi_irecv(y%combuf(rcv_pt),nerv,& + & psb_mpi_ipk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + idx_pt = snd_pt + call y%gth(idx_pt,nesd,idx) + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_int_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),nesd,& + & psb_mpi_ipk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - p2ptag = psb_int_swap_tag - call mpi_irecv(y%combuf(rcv_pt),nerv,& - & psb_mpi_ipk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - pnti = pnti + nerv + nesd + 3 - end do - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - idx_pt = snd_pt - call y%gth(idx_pt,nesd,idx) - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - p2ptag = psb_int_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if ((nesd>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(snd_pt),nesd,& - & psb_mpi_ipk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - p2ptag = psb_int_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (proc_to_comm /= me)then - if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_int_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) + call y%sct(rcv_pt,nerv,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(rcv_pt:rcv_pt+nerv-1) - call y%sct(rcv_pt,nerv,idx,beta) - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for everybody, clean up - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_iswap_vidx_vect - -! -! -! Subroutine: psi_iswapdata_multivect -! Data exchange among processes. -! -! Takes care of Y an encaspulated multivector. -! -! -subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_iswapdata_multivect - use psb_i_base_multivect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_iswap_vidx_vect + + ! + ! + ! Subroutine: psi_iswapdata_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_multivect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_), target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) return -end subroutine psi_iswapdata_multivect +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_iswapdata_multivect + + + ! + ! + ! Subroutine: psi_iswap_vidx_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods + ! of multivectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_iswap_vidx_multivect(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_iswap_vidx_multivect -! Data exchange among processes. -! -! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods -! of multivectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_iswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_iswap_vidx_multivect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_i_base_multivect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_multivect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n = y%get_ncols() - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + n = y%get_ncols() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_int_swap_tag + call mpi_irecv(y%combuf(rcv_pt),n*nerv,& + & psb_mpi_ipk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call y%gth(idx_pt,snd_pt,nesd,idx) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait for device + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_int_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),n*nesd,& + & psb_mpi_ipk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - p2ptag = psb_int_swap_tag - call mpi_irecv(y%combuf(rcv_pt),n*nerv,& - & psb_mpi_ipk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call y%gth(idx_pt,snd_pt,nesd,idx) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait for device - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_int_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - if ((nesd>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(snd_pt),n*nesd,& - & psb_mpi_ipk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_int_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm /= me)then - if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_int_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+n*nerv-1) + call y%sct(idx_pt,rcv_pt,nerv,idx,beta) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(rcv_pt:rcv_pt+n*nerv-1) - call y%sct(idx_pt,rcv_pt,nerv,idx,beta) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for com, cleanup comid - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_iswap_vidx_multivect + return + end subroutine psi_iswap_vidx_multivect +end submodule psi_i_swapdata_impl diff --git a/base/comm/internals/psi_iswaptran.F90 b/base/comm/internals/psi_iswaptran.F90 index 9b440424..ce4e64e7 100644 --- a/base/comm/internals/psi_iswaptran.F90 +++ b/base/comm/internals/psi_iswaptran.F90 @@ -91,418 +91,406 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data) +submodule (psi_i_comm_v_mod) psi_i_swaptran_impl + use psb_base_mod +contains + module subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_iswaptran_vect - use psb_i_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_vect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_iswaptran_vect + end subroutine psi_iswaptran_vect + + ! + ! + ! Subroutine: psi_itran_vidx_vect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated vector. Relies on the gather/scatter methods + ! of vectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_itran_vidx_vect(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_itran_vidx_vect -! Data exchange among processes. -! -! Takes care of Y an encapsulated vector. Relies on the gather/scatter methods -! of vectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_itran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_itran_vidx_vect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_i_base_vect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_vect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - p2ptag = psb_int_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - call mpi_irecv(y%combuf(snd_pt),nesd,& - & psb_mpi_ipk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - idx_pt = rcv_pt - call y%gth(idx_pt,nerv,idx) - - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - p2ptag = psb_int_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if ((nerv>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(rcv_pt),nerv,& - & psb_mpi_ipk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + p2ptag = psb_int_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + call mpi_irecv(y%combuf(snd_pt),nesd,& + & psb_mpi_ipk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + idx_pt = rcv_pt + call y%gth(idx_pt,nerv,idx) + + pnti = pnti + nerv + nesd + 3 + end do - pnti = pnti + nerv + nesd + 3 - end do - end if + ! + ! Then wait + ! + call y%device_wait() - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... + if (debug) write(*,*) me,' isend' ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_int_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),nerv,& + & psb_mpi_ipk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - p2ptag = psb_int_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (proc_to_comm /= me)then - if (nerv>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_int_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+nesd-1) + call y%sct(snd_pt,nesd,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(snd_pt:snd_pt+nesd-1) - call y%sct(snd_pt,nesd,idx,beta) - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for everybody, clean up - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return + return -end subroutine psi_itran_vidx_vect + end subroutine psi_itran_vidx_vect -! -! -! -! -! Subroutine: psi_iswaptran_multivect -! Data exchange among processes. -! -! Takes care of Y an encaspulated multivector. -! -! -subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data) + ! + ! + ! + ! + ! Subroutine: psi_iswaptran_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_iswaptran_multivect - use psb_i_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_multivect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) @@ -510,273 +498,266 @@ subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data) end subroutine psi_iswaptran_multivect -! -! -! Subroutine: psi_itran_vidx_multivect -! Data exchange among processes. -! -! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods -! of multivectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_itran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_itran_vidx_multivect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_i_base_multivect_mod + ! + ! + ! Subroutine: psi_itran_vidx_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods + ! of multivectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_itran_vidx_multivect(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_multivect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n = y%get_ncols() - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + n = y%get_ncols() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_int_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt + call mpi_irecv(y%combuf(snd_pt),n*nesd,& + & psb_mpi_ipk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call y%gth(idx_pt,rcv_pt,nerv,idx) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait for device + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_int_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),n*nerv,& + & psb_mpi_ipk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_int_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt - call mpi_irecv(y%combuf(snd_pt),n*nesd,& - & psb_mpi_ipk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call y%gth(idx_pt,rcv_pt,nerv,idx) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait for device - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_int_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - if ((nerv>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(rcv_pt),n*nerv,& - & psb_mpi_ipk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_int_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm /= me)then - if (nerv>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_int_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(snd_pt:snd_pt+n*nesd-1) - call y%sct(idx_pt,snd_pt,nesd,idx,beta) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! - ! Waited for com, cleanup comid - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if (debug) write(*,*) me,' done' - end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+n*nesd-1) + call y%sct(idx_pt,snd_pt,nesd,idx,beta) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - call psb_erractionrestore(err_act) - return + ! + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null -9999 call psb_error_handler(ctxt,err_act) + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if - return -end subroutine psi_itran_vidx_multivect + call psb_erractionrestore(err_act) + return +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_itran_vidx_multivect +end submodule psi_i_swaptran_impl diff --git a/base/comm/internals/psi_lovrl_restr.f90 b/base/comm/internals/psi_lovrl_restr.f90 index d3f6c913..ebc7a8d1 100644 --- a/base/comm/internals/psi_lovrl_restr.f90 +++ b/base/comm/internals/psi_lovrl_restr.f90 @@ -35,90 +35,90 @@ ! ! ! -subroutine psi_lovrl_restr_vect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_lovrl_restr_vect - use psb_l_base_vect_mod - - implicit none - - class(psb_l_base_vect_type) :: x - integer(psb_lpk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_lovrl_restr_vect' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,lzero) - - call psb_erractionrestore(err_act) - return +submodule (psi_l_comm_v_mod) psi_l_ovrl_restr_v_impl + use psb_base_mod +contains + module subroutine psi_lovrl_restr_vect(x,xs,desc_a,info) + + implicit none + + class(psb_l_base_vect_type) :: x + integer(psb_lpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_lovrl_restr_vect' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,lzero) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_lovrl_restr_vect + return + end subroutine psi_lovrl_restr_vect -subroutine psi_lovrl_restr_multivect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_lovrl_restr_multivect - use psb_l_base_vect_mod + module subroutine psi_lovrl_restr_multivect(x,xs,desc_a,info) - implicit none + implicit none - class(psb_l_base_multivect_type) :: x - integer(psb_lpk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type) :: x + integer(psb_lpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz,nc - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz,nc + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err - name='psi_lovrl_restr_mv' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif + name='psi_lovrl_restr_mv' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif - isz = size(desc_a%ovrlap_elem,1) - call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,lzero) + isz = size(desc_a%ovrlap_elem,1) + call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,lzero) - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_lovrl_restr_multivect + return + end subroutine psi_lovrl_restr_multivect +end submodule psi_l_ovrl_restr_v_impl diff --git a/base/comm/internals/psi_lovrl_save.f90 b/base/comm/internals/psi_lovrl_save.f90 index 0eb623da..4e3b26a9 100644 --- a/base/comm/internals/psi_lovrl_save.f90 +++ b/base/comm/internals/psi_lovrl_save.f90 @@ -34,103 +34,101 @@ ! for the transpose matrix-vector product when there is a nonempty overlap. ! ! -subroutine psi_lovrl_save_vect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_lovrl_save_vect - use psb_realloc_mod - use psb_l_base_vect_mod - - implicit none - - class(psb_l_base_vect_type) :: x - integer(psb_lpk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_dovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) - - call psb_erractionrestore(err_act) - return +submodule (psi_l_comm_v_mod) psi_l_ovrl_save_v_impl + use psb_base_mod +contains + module subroutine psi_lovrl_save_vect(x,xs,desc_a,info) + + implicit none + + class(psb_l_base_vect_type) :: x + integer(psb_lpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_lovrl_save_vect - -subroutine psi_lovrl_save_multivect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_lovrl_save_multivect - use psb_realloc_mod - use psb_l_base_vect_mod - - implicit none - - class(psb_l_base_multivect_type) :: x - integer(psb_lpk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, nc - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_dovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = x%get_ncols() - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_lovrl_save_vect + + module subroutine psi_lovrl_save_multivect(x,xs,desc_a,info) + + implicit none + + class(psb_l_base_multivect_type) :: x + integer(psb_lpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, nc + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_lovrl_save_multivect + return + end subroutine psi_lovrl_save_multivect +end submodule psi_l_ovrl_save_v_impl diff --git a/base/comm/internals/psi_lovrl_upd.f90 b/base/comm/internals/psi_lovrl_upd.f90 index 1371e02b..0d1701e2 100644 --- a/base/comm/internals/psi_lovrl_upd.f90 +++ b/base/comm/internals/psi_lovrl_upd.f90 @@ -36,169 +36,167 @@ ! ! ! -subroutine psi_lovrl_upd_vect(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_lovrl_upd_vect - use psb_realloc_mod - use psb_l_base_vect_mod - - implicit none - - class(psb_l_base_vect_type) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_lpk_), allocatable :: xs(:) - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, nx, ndm - integer(psb_ipk_) :: err_act, i, idx - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - - name='psi_lovrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - nx = size(desc_a%ovrlap_elem,1) - call psb_realloc(nx,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_Dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - if (update /= psb_sum_) then - call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) - ! switch on update type - - select case (update) - case(psb_square_root_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i) = xs(i)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i) = xs(i)/real(ndm) - end do - case(psb_setzero_) - do i=1,nx - if (me /= desc_a%ovrlap_elem(i,3))& - & xs(i) = lzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) +submodule (psi_l_comm_v_mod) psi_l_ovrl_upd_v_impl + use psb_base_mod +contains + module subroutine psi_lovrl_upd_vect(x,desc_a,update,info) + + implicit none + + class(psb_l_base_vect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_lpk_), allocatable :: xs(:) + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, nx, ndm + integer(psb_ipk_) :: err_act, i, idx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_lovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end select - call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,lzero) - end if - - call psb_erractionrestore(err_act) - return + endif + nx = size(desc_a%ovrlap_elem,1) + call psb_realloc(nx,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i) = lzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,lzero) + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_lovrl_upd_vect - -subroutine psi_lovrl_upd_multivect(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_lovrl_upd_multivect - use psb_realloc_mod - use psb_l_base_vect_mod - - implicit none - - class(psb_l_base_multivect_type) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_lpk_), allocatable :: xs(:,:) - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, ndm, nx, nc - integer(psb_ipk_) :: err_act, i, idx - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - - name='psi_lovrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - nx = size(desc_a%ovrlap_elem,1) - nc = x%get_ncols() - call psb_realloc(nx,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_Dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - if (update /= psb_sum_) then - call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) - ! switch on update type - - select case (update) - case(psb_square_root_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i,:) = xs(i,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i,:) = xs(i,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,nx - if (me /= desc_a%ovrlap_elem(i,3))& - & xs(i,:) = lzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) + return + end subroutine psi_lovrl_upd_vect + + module subroutine psi_lovrl_upd_multivect(x,desc_a,update,info) + + implicit none + + class(psb_l_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_lpk_), allocatable :: xs(:,:) + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, ndm, nx, nc + integer(psb_ipk_) :: err_act, i, idx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_lovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end select - call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,lzero) - end if - - call psb_erractionrestore(err_act) - return + endif + nx = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(nx,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i,:) = lzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,lzero) + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_lovrl_upd_multivect + return + end subroutine psi_lovrl_upd_multivect +end submodule psi_l_ovrl_upd_v_impl diff --git a/base/comm/internals/psi_lswapdata.F90 b/base/comm/internals/psi_lswapdata.F90 index a413cb2d..7d9e13a4 100644 --- a/base/comm/internals/psi_lswapdata.F90 +++ b/base/comm/internals/psi_lswapdata.F90 @@ -89,676 +89,659 @@ ! ! ! -subroutine psi_lswapdata_vect(flag,beta,y,desc_a,work,info,data) +submodule (psi_l_comm_v_mod) psi_l_swapdata_impl + use psb_base_mod +contains + subroutine psi_lswapdata_vect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_lswapdata_vect - use psb_l_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_l_base_vect_type) :: y - integer(psb_lpk_) :: beta - integer(psb_lpk_), target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) return -end subroutine psi_lswapdata_vect +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_lswapdata_vect + + + ! + ! + ! Subroutine: psi_lswap_vidx_vect + ! Data exchange among processes. + ! + ! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods + ! of vectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_lswap_vidx_vect(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_lswap_vidx_vect -! Data exchange among processes. -! -! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods -! of vectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_lswap_vidx_vect(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_lswap_vidx_vect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_l_base_vect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_l_base_vect_type) :: y - integer(psb_lpk_) :: beta - integer(psb_lpk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, nesd, nerv - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, n - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),& + & iret, nesd, nerv + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + rcv_pt = 1+pnti+psb_n_elem_recv_ + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_long_swap_tag + call mpi_irecv(y%combuf(rcv_pt),nerv,& + & psb_mpi_lpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + idx_pt = snd_pt + call y%gth(idx_pt,nesd,idx) + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),nesd,& + & psb_mpi_lpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - p2ptag = psb_long_swap_tag - call mpi_irecv(y%combuf(rcv_pt),nerv,& - & psb_mpi_lpk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - pnti = pnti + nerv + nesd + 3 - end do - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - idx_pt = snd_pt - call y%gth(idx_pt,nesd,idx) - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - p2ptag = psb_long_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if ((nesd>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(snd_pt),nesd,& - & psb_mpi_lpk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - p2ptag = psb_long_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (proc_to_comm /= me)then - if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) + call y%sct(rcv_pt,nerv,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(rcv_pt:rcv_pt+nerv-1) - call y%sct(rcv_pt,nerv,idx,beta) - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for everybody, clean up - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_lswap_vidx_vect - -! -! -! Subroutine: psi_lswapdata_multivect -! Data exchange among processes. -! -! Takes care of Y an encaspulated multivector. -! -! -subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_lswapdata_multivect - use psb_l_base_multivect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_lswap_vidx_vect + + ! + ! + ! Subroutine: psi_lswapdata_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,work,info,data) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_l_base_multivect_type) :: y - integer(psb_lpk_) :: beta - integer(psb_lpk_), target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) return -end subroutine psi_lswapdata_multivect +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_lswapdata_multivect + + + ! + ! + ! Subroutine: psi_lswap_vidx_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods + ! of multivectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_lswap_vidx_multivect(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_lswap_vidx_multivect -! Data exchange among processes. -! -! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods -! of multivectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_lswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_lswap_vidx_multivect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_l_base_multivect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_l_base_multivect_type) :: y - integer(psb_lpk_) :: beta - integer(psb_lpk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n = y%get_ncols() - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + n = y%get_ncols() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_long_swap_tag + call mpi_irecv(y%combuf(rcv_pt),n*nerv,& + & psb_mpi_lpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call y%gth(idx_pt,snd_pt,nesd,idx) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait for device + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),n*nesd,& + & psb_mpi_lpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - p2ptag = psb_long_swap_tag - call mpi_irecv(y%combuf(rcv_pt),n*nerv,& - & psb_mpi_lpk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call y%gth(idx_pt,snd_pt,nesd,idx) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait for device - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_long_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - if ((nesd>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(snd_pt),n*nesd,& - & psb_mpi_lpk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_long_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm /= me)then - if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+n*nerv-1) + call y%sct(idx_pt,rcv_pt,nerv,idx,beta) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(rcv_pt:rcv_pt+n*nerv-1) - call y%sct(idx_pt,rcv_pt,nerv,idx,beta) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for com, cleanup comid - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_lswap_vidx_multivect + return + end subroutine psi_lswap_vidx_multivect +end submodule psi_l_swapdata_impl diff --git a/base/comm/internals/psi_lswaptran.F90 b/base/comm/internals/psi_lswaptran.F90 index f92fc344..094fc574 100644 --- a/base/comm/internals/psi_lswaptran.F90 +++ b/base/comm/internals/psi_lswaptran.F90 @@ -91,418 +91,406 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_lswaptran_vect(flag,beta,y,desc_a,work,info,data) +submodule (psi_l_comm_v_mod) psi_l_swaptran_impl + use psb_base_mod +contains + module subroutine psi_lswaptran_vect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_lswaptran_vect - use psb_l_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_l_base_vect_type) :: y - integer(psb_lpk_) :: beta - integer(psb_lpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_lswaptran_vect + end subroutine psi_lswaptran_vect + + ! + ! + ! Subroutine: psi_ltran_vidx_vect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated vector. Relies on the gather/scatter methods + ! of vectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_ltran_vidx_vect(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_ltran_vidx_vect -! Data exchange among processes. -! -! Takes care of Y an encapsulated vector. Relies on the gather/scatter methods -! of vectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_ltran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_ltran_vidx_vect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_l_base_vect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_l_base_vect_type) :: y - integer(psb_lpk_) :: beta - integer(psb_lpk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - p2ptag = psb_long_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - call mpi_irecv(y%combuf(snd_pt),nesd,& - & psb_mpi_lpk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - idx_pt = rcv_pt - call y%gth(idx_pt,nerv,idx) - - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - p2ptag = psb_long_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if ((nerv>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(rcv_pt),nerv,& - & psb_mpi_lpk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + call mpi_irecv(y%combuf(snd_pt),nesd,& + & psb_mpi_lpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + idx_pt = rcv_pt + call y%gth(idx_pt,nerv,idx) + + pnti = pnti + nerv + nesd + 3 + end do - pnti = pnti + nerv + nesd + 3 - end do - end if + ! + ! Then wait + ! + call y%device_wait() - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... + if (debug) write(*,*) me,' isend' ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),nerv,& + & psb_mpi_lpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - p2ptag = psb_long_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (proc_to_comm /= me)then - if (nerv>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+nesd-1) + call y%sct(snd_pt,nesd,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(snd_pt:snd_pt+nesd-1) - call y%sct(snd_pt,nesd,idx,beta) - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for everybody, clean up - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return + return -end subroutine psi_ltran_vidx_vect + end subroutine psi_ltran_vidx_vect -! -! -! -! -! Subroutine: psi_lswaptran_multivect -! Data exchange among processes. -! -! Takes care of Y an encaspulated multivector. -! -! -subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,work,info,data) + ! + ! + ! + ! + ! Subroutine: psi_lswaptran_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_lswaptran_multivect - use psb_l_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_l_base_multivect_type) :: y - integer(psb_lpk_) :: beta - integer(psb_lpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) @@ -510,273 +498,266 @@ subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,work,info,data) end subroutine psi_lswaptran_multivect -! -! -! Subroutine: psi_ltran_vidx_multivect -! Data exchange among processes. -! -! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods -! of multivectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_ltran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_ltran_vidx_multivect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_l_base_multivect_mod + ! + ! + ! Subroutine: psi_ltran_vidx_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods + ! of multivectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_ltran_vidx_multivect(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_l_base_multivect_type) :: y - integer(psb_lpk_) :: beta - integer(psb_lpk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n = y%get_ncols() - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + n = y%get_ncols() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt + call mpi_irecv(y%combuf(snd_pt),n*nesd,& + & psb_mpi_lpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call y%gth(idx_pt,rcv_pt,nerv,idx) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait for device + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),n*nerv,& + & psb_mpi_lpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_long_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt - call mpi_irecv(y%combuf(snd_pt),n*nesd,& - & psb_mpi_lpk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call y%gth(idx_pt,rcv_pt,nerv,idx) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait for device - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_long_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - if ((nerv>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(rcv_pt),n*nerv,& - & psb_mpi_lpk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_long_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm /= me)then - if (nerv>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(snd_pt:snd_pt+n*nesd-1) - call y%sct(idx_pt,snd_pt,nesd,idx,beta) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! - ! Waited for com, cleanup comid - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if (debug) write(*,*) me,' done' - end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+n*nesd-1) + call y%sct(idx_pt,snd_pt,nesd,idx,beta) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - call psb_erractionrestore(err_act) - return + ! + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null -9999 call psb_error_handler(ctxt,err_act) + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if - return -end subroutine psi_ltran_vidx_multivect + call psb_erractionrestore(err_act) + return +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ltran_vidx_multivect +end submodule psi_l_swaptran_impl diff --git a/base/comm/internals/psi_movrl_restr_a.f90 b/base/comm/internals/psi_movrl_restr_a.f90 index d884ad63..a660e2fd 100644 --- a/base/comm/internals/psi_movrl_restr_a.f90 +++ b/base/comm/internals/psi_movrl_restr_a.f90 @@ -34,98 +34,100 @@ ! for the transpose matrix-vector product when there is a nonempty overlap. ! ! -subroutine psi_movrl_restrr1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_movrl_restrr1 - - implicit none - - integer(psb_mpk_), intent(inout) :: x(:) - integer(psb_mpk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_movrl_restrr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return +submodule (psi_m_comm_a_mod) psi_m_ovrl_restr_a_impl + use psb_base_mod +contains + module subroutine psi_movrl_restrr1(x,xs,desc_a,info) + + implicit none + + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_mpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_movrl_restrr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_movrl_restrr1 + return + end subroutine psi_movrl_restrr1 -subroutine psi_movrl_restrr2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_movrl_restrr2 + module subroutine psi_movrl_restrr2(x,xs,desc_a,info) - implicit none + implicit none - integer(psb_mpk_), intent(inout) :: x(:,:) - integer(psb_mpk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_), intent(inout) :: x(:,:) + integer(psb_mpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err - name='psi_movrl_restrr2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif + name='psi_movrl_restrr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif - if (size(x,2) /= size(xs,2)) then - info = psb_err_internal_error_ - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif + if (size(x,2) /= size(xs,2)) then + info = psb_err_internal_error_ + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif - isz = size(desc_a%ovrlap_elem,1) + isz = size(desc_a%ovrlap_elem,1) - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_movrl_restrr2 + return + end subroutine psi_movrl_restrr2 +end submodule psi_m_ovrl_restr_a_impl diff --git a/base/comm/internals/psi_movrl_save_a.f90 b/base/comm/internals/psi_movrl_save_a.f90 index 398ea24a..d9d0e603 100644 --- a/base/comm/internals/psi_movrl_save_a.f90 +++ b/base/comm/internals/psi_movrl_save_a.f90 @@ -34,108 +34,104 @@ ! These subroutines save the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap. ! -subroutine psi_movrl_saver1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_movrl_saver1 - - use psb_realloc_mod - - implicit none - - integer(psb_mpk_), intent(inout) :: x(:) - integer(psb_mpk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_movrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return +submodule (psi_m_comm_a_mod) psi_m_ovrl_save_a_impl + use psb_base_mod +contains + module subroutine psi_movrl_saver1(x,xs,desc_a,info) + implicit none + + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_mpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_movrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_movrl_saver1 - - -subroutine psi_movrl_saver2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_movrl_saver2 - - use psb_realloc_mod - - implicit none - - integer(psb_mpk_), intent(inout) :: x(:,:) - integer(psb_mpk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_movrl_saver2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_movrl_saver1 + + + module subroutine psi_movrl_saver2(x,xs,desc_a,info) + implicit none + + integer(psb_mpk_), intent(inout) :: x(:,:) + integer(psb_mpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_movrl_saver2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_movrl_saver2 + return + end subroutine psi_movrl_saver2 +end submodule psi_m_ovrl_save_a_impl diff --git a/base/comm/internals/psi_movrl_upd_a.f90 b/base/comm/internals/psi_movrl_upd_a.f90 index c4ffa64f..f31d4cfa 100644 --- a/base/comm/internals/psi_movrl_upd_a.f90 +++ b/base/comm/internals/psi_movrl_upd_a.f90 @@ -32,143 +32,143 @@ ! Subroutine: psi_movrl_update ! These subroutines update the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap, -! or for the application of Additive Schwarz preconditioners. +! or for the application of Additive Schwarz preconditioners. ! ! -subroutine psi_movrl_updr1(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_movrl_updr1 - - implicit none - - integer(psb_mpk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_movrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = mzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return +submodule (psi_m_comm_a_mod) psi_m_ovrl_upd_a_impl + use psb_base_mod +contains + module subroutine psi_movrl_updr1(x,desc_a,update,info) + implicit none + + integer(psb_mpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_movrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = mzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_movrl_updr1 - -subroutine psi_movrl_updr2(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_movrl_updr2 - - implicit none - - integer(psb_mpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_movrl_updr2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = mzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_movrl_updr1 + + module subroutine psi_movrl_updr2(x,desc_a,update,info) + implicit none + + integer(psb_mpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_movrl_updr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = mzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_movrl_updr2 + return + end subroutine psi_movrl_updr2 +end submodule psi_m_ovrl_upd_a_impl diff --git a/base/comm/internals/psi_mswapdata_a.F90 b/base/comm/internals/psi_mswapdata_a.F90 index 169dd46a..7a00f36c 100644 --- a/base/comm/internals/psi_mswapdata_a.F90 +++ b/base/comm/internals/psi_mswapdata_a.F90 @@ -84,912 +84,899 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_mswapdatam(flag,n,beta,y,desc_a,work,info,data) +submodule (psi_m_comm_a_mod) psi_m_swapdata_a_impl + use psb_base_mod +contains + module subroutine psi_mswapdatam(flag,n,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_mswapdatam - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_mpk_) :: y(:,:), beta - integer(psb_mpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info +integer(psb_mpk_) :: y(:,:), beta +integer(psb_mpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_mswapdatam + end subroutine psi_mswapdatam -subroutine psi_mswapidxm(ctxt,icomm,flag,n,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) + module subroutine psi_mswapidxm(ctxt,flag,n,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) - use psi_mod, psb_protect_name => psi_mswapidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_mpk_) :: y(:,:), beta - integer(psb_mpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - - integer(psb_mpk_) :: np, me, nesd, nerv - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info +integer(psb_mpk_) :: y(:,:), beta +integer(psb_mpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + + integer(psb_mpk_) :: np, me, nesd, nerv + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_mpk_) :: icomm + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + +integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if - ! prepare info for communications + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + end if - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_mpk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_mpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int4_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_mpk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_mpk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int4_swap_tag + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int4_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*)& + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_sync) then - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + else if (swap_send) then - if (proc_to_comm < me) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - end do + end if + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then + end if - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int4_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_mpk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_int4_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),n*nesd,& - & psb_mpi_mpk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),n*nesd,& - & psb_mpi_mpk_,prcid(i),& - & p2ptag,icomm,iret) - end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_int4_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*)& - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_mswapidxm + end subroutine psi_mswapidxm + + ! + ! + ! Subroutine: psi_mswapdatav + ! Implements the data exchange among processes. Essentially this is doing + ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but + ! it is capable of pruning empty exchanges, which are very likely in out + ! application environment. All the variants have the same structure + ! In all these subroutines X may be: I Integer + ! S real(psb_spk_) + ! D real(psb_dpk_) + ! C complex(psb_spk_) + ! Z complex(psb_dpk_) + ! Basically the operation is as follows: on each process, we identify + ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); + ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y + ! but only on the elements involved in the UNPACK operation. + ! Thus: for halo data exchange, the receive section is confined in the + ! halo indices, and BETA=0, whereas for overlap exchange the receive section + ! is scattered in the owned indices, and BETA=1. + ! The first routine picks the desired exchange index list and passes it to the second. + ! + ! Arguments: + ! flag - integer Choose the algorithm for data exchange: + ! this is chosen through bit fields. + ! 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 + ! if (swap_mpi): use underlying MPI_ALLTOALLV. + ! if (swap_sync): use PSB_SND and PSB_RCV in + ! synchronized pairs + ! if (swap_send .and. swap_recv): use mpi_irecv + ! and mpi_send + ! if (swap_send): use psb_snd (but need another + ! call with swap_recv to complete) + ! if (swap_recv): use psb_rcv (completing a + ! previous call with swap_send) + ! + ! + ! n - integer Number of columns in Y + ! beta - integer Choose overwrite or sum. + ! y(:) - integer The data area + ! desc_a - type(psb_desc_type). The communication descriptor. + ! work(:) - integer Buffer space. If not sufficient, will do + ! our own internal allocation. + ! info - integer. return code. + ! data - integer which list is to be used to exchange data + ! default psb_comm_halo_ + ! psb_comm_halo_ use halo_index + ! psb_comm_ext_ use ext_index + ! psb_comm_ovrl_ use ovrl_index + ! psb_comm_mov_ use ovr_mst_idx + ! + ! + module subroutine psi_mswapdatav(flag,beta,y,desc_a,work,info,data) -! -! -! Subroutine: psi_mswapdatav -! Implements the data exchange among processes. Essentially this is doing -! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! The first routine picks the desired exchange index list and passes it to the second. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! 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 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - integer Choose overwrite or sum. -! y(:) - integer The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - integer Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_mswapdatav(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_mswapdatav - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_mpk_) :: y(:), beta - integer(psb_mpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:), beta + integer(psb_mpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif - return -end subroutine psi_mswapdatav + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if -! -! -! Subroutine: psi_mswapdataidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_mswapidxv(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) + call psi_swapdata(ctxt,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) - use psi_mod, psb_protect_name => psi_mswapidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_mswapdatav + + + ! + ! + ! Subroutine: psi_mswapdataidxv + ! Does the data exchange among processes. + ! + ! The real workhorse: the outer routines will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_mswapidxv(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psb_error_mod + use psb_desc_mod + use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_mpk_) :: y(:), beta - integer(psb_mpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:), beta + integer(psb_mpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + integer(psb_mpk_) :: icomm + logical, parameter :: usersend=.false. + + integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications + ! prepare info for communications - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - end do + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - end if - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_mpk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_mpk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. end if - else if (swap_sync) then - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + if (do_send) then - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_mpk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_mpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int4_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int4_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),nerv,& - & psb_mpi_mpk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int4_swap_tag - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int4_swap_tag + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int4_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),nesd,& - & psb_mpi_mpk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),nesd,& - & psb_mpi_mpk_,prcid(i),& - & p2ptag,icomm,iret) + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) end if + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int4_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_mswapidxv + end subroutine psi_mswapidxv +end submodule psi_m_swapdata_a_impl diff --git a/base/comm/internals/psi_mswaptran_a.F90 b/base/comm/internals/psi_mswaptran_a.F90 index f8346fe1..07672d39 100644 --- a/base/comm/internals/psi_mswaptran_a.F90 +++ b/base/comm/internals/psi_mswaptran_a.F90 @@ -88,922 +88,909 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_mswaptranm(flag,n,beta,y,desc_a,work,info,data) +submodule (psi_m_comm_a_mod) psi_m_swaptran_a_impl + use psb_base_mod +contains + module subroutine psi_mswaptranm(flag,n,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_mswaptranm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_mpk_) :: y(:,:), beta - integer(psb_mpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, err_act, totxch, data_ - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:,:), beta + integer(psb_mpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, err_act, totxch, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return -end subroutine psi_mswaptranm -subroutine psi_mtranidxm(ctxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) +9999 call psb_error_handler(ctxt,err_act) - use psi_mod, psb_protect_name => psi_mtranidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_mswaptranm + + module subroutine psi_mtranidxm(ctxt,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_mpk_) :: y(:,:), beta - integer(psb_mpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:,:), beta + integer(psb_mpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + integer(psb_mpk_) :: icomm + logical, parameter :: usersend=.false. + + integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if - ! prepare info for communications + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + if (do_send) then - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd + call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 end if - albf=.true. - end if - if (do_send) then - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) + ! Case SWAP_MPI + if (swap_mpi) then - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_mpk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_mpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if - end if + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int4_swap_tag + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int4_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - ! Case SWAP_MPI - if (swap_mpi) then + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_mpk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_mpk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int4_swap_tag - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send',& + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int4_swap_tag - call mpi_irecv(sndbuf(snd_pt),n*nesd,& - & psb_mpi_mpk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + else if (swap_send) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + else if (swap_recv) then - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int4_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_mpk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_mpk_,prcid(i),& - & p2ptag,icomm,iret) - end if + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 + end if - end do + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int4_swap_tag + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send',& - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_mtranidxm -! -! -! Subroutine: psi_mswaptranv -! Implements the data exchange among processes. This is similar to Xswapdata, but -! the list is read "in reverse", i.e. indices that are normally SENT are used -! for the RECEIVE part and vice-versa. This is the basic data exchange operation -! for doing the product of a sparse matrix by a vector. -! Essentially this is doing a variable all-to-all data exchange -! (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! The first routine picks the desired exchange index list and passes it to the second. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! 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 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - integer Choose overwrite or sum. -! y(:) - integer The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - integer Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_mswaptranv(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_mswaptranv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + end subroutine psi_mtranidxm + ! + ! + ! Subroutine: psi_mswaptranv + ! Implements the data exchange among processes. This is similar to Xswapdata, but + ! the list is read "in reverse", i.e. indices that are normally SENT are used + ! for the RECEIVE part and vice-versa. This is the basic data exchange operation + ! for doing the product of a sparse matrix by a vector. + ! Essentially this is doing a variable all-to-all data exchange + ! (ALLTOALLV in MPI parlance), but + ! it is capable of pruning empty exchanges, which are very likely in out + ! application environment. All the variants have the same structure + ! In all these subroutines X may be: I Integer + ! S real(psb_spk_) + ! D real(psb_dpk_) + ! C complex(psb_spk_) + ! Z complex(psb_dpk_) + ! Basically the operation is as follows: on each process, we identify + ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); + ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y + ! but only on the elements involved in the UNPACK operation. + ! Thus: for halo data exchange, the receive section is confined in the + ! halo indices, and BETA=0, whereas for overlap exchange the receive section + ! is scattered in the owned indices, and BETA=1. + ! The first routine picks the desired exchange index list and passes it to the second. + ! + ! Arguments: + ! flag - integer Choose the algorithm for data exchange: + ! this is chosen through bit fields. + ! 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 + ! if (swap_mpi): use underlying MPI_ALLTOALLV. + ! if (swap_sync): use PSB_SND and PSB_RCV in + ! synchronized pairs + ! if (swap_send .and. swap_recv): use mpi_irecv + ! and mpi_send + ! if (swap_send): use psb_snd (but need another + ! call with swap_recv to complete) + ! if (swap_recv): use psb_rcv (completing a + ! previous call with swap_send) + ! + ! + ! n - integer Number of columns in Y + ! beta - integer Choose overwrite or sum. + ! y(:) - integer The data area + ! desc_a - type(psb_desc_type). The communication descriptor. + ! work(:) - integer Buffer space. If not sufficient, will do + ! our own internal allocation. + ! info - integer. return code. + ! data - integer which list is to be used to exchange data + ! default psb_comm_halo_ + ! psb_comm_halo_ use halo_index + ! psb_comm_ext_ use ext_index + ! psb_comm_ovrl_ use ovrl_index + ! psb_comm_mov_ use ovr_mst_idx + ! + ! + module subroutine psi_mswaptranv(flag,beta,y,desc_a,work,info,data) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_mpk_) :: y(:), beta - integer(psb_mpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:), beta + integer(psb_mpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif - return -end subroutine psi_mswaptranv + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if -! -! -! Subroutine: psi_mtranidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_mtranidxv(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) + call psi_swaptran(ctxt,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 - use psi_mod, psb_protect_name => psi_mtranidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_mswaptranv + + + ! + ! + ! Subroutine: psi_mtranidxv + ! Does the data exchange among processes. + ! + ! The real workhorse: the outer routines will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_mtranidxv(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_mpk_) :: y(:), beta - integer(psb_mpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:), beta + integer(psb_mpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_mpk_) :: icomm + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications + ! prepare info for communications - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - end do + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - end if - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_mpk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_mpk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - else if (swap_sync) then + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_mpk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_mpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int4_swap_tag + call mpi_irecv(sndbuf(snd_pt),nesd,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int4_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm < me) then + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int4_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int4_swap_tag - call mpi_irecv(sndbuf(snd_pt),nesd,& - & psb_mpi_mpk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + end if - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int4_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),nerv,& - & psb_mpi_mpk_,prcid(i),& - & p2ptag, icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),nerv,& - & psb_mpi_mpk_,prcid(i),& - & p2ptag, icomm,iret) - end if + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int4_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_mtranidxv + end subroutine psi_mtranidxv +end submodule psi_m_swaptran_a_impl diff --git a/base/comm/internals/psi_sovrl_restr.f90 b/base/comm/internals/psi_sovrl_restr.f90 index 86361fba..1ce96355 100644 --- a/base/comm/internals/psi_sovrl_restr.f90 +++ b/base/comm/internals/psi_sovrl_restr.f90 @@ -35,90 +35,90 @@ ! ! ! -subroutine psi_sovrl_restr_vect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_sovrl_restr_vect - use psb_s_base_vect_mod - - implicit none - - class(psb_s_base_vect_type) :: x - real(psb_spk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_sovrl_restr_vect' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,szero) - - call psb_erractionrestore(err_act) - return +submodule (psi_s_comm_v_mod) psi_s_ovrl_restr_v_impl + use psb_base_mod +contains + module subroutine psi_sovrl_restr_vect(x,xs,desc_a,info) + + implicit none + + class(psb_s_base_vect_type) :: x + real(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_sovrl_restr_vect' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,szero) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_sovrl_restr_vect + return + end subroutine psi_sovrl_restr_vect -subroutine psi_sovrl_restr_multivect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_sovrl_restr_multivect - use psb_s_base_vect_mod + module subroutine psi_sovrl_restr_multivect(x,xs,desc_a,info) - implicit none + implicit none - class(psb_s_base_multivect_type) :: x - real(psb_spk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type) :: x + real(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz,nc - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz,nc + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err - name='psi_sovrl_restr_mv' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif + name='psi_sovrl_restr_mv' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif - isz = size(desc_a%ovrlap_elem,1) - call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,szero) + isz = size(desc_a%ovrlap_elem,1) + call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,szero) - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_sovrl_restr_multivect + return + end subroutine psi_sovrl_restr_multivect +end submodule psi_s_ovrl_restr_v_impl diff --git a/base/comm/internals/psi_sovrl_restr_a.f90 b/base/comm/internals/psi_sovrl_restr_a.f90 index c1295187..2e1d53ae 100644 --- a/base/comm/internals/psi_sovrl_restr_a.f90 +++ b/base/comm/internals/psi_sovrl_restr_a.f90 @@ -34,98 +34,100 @@ ! for the transpose matrix-vector product when there is a nonempty overlap. ! ! -subroutine psi_sovrl_restrr1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_sovrl_restrr1 - - implicit none - - real(psb_spk_), intent(inout) :: x(:) - real(psb_spk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_sovrl_restrr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return +submodule (psi_s_comm_a_mod) psi_s_ovrl_restr_a_impl + use psb_base_mod +contains + module subroutine psi_sovrl_restrr1(x,xs,desc_a,info) + + implicit none + + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_sovrl_restrr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_sovrl_restrr1 + return + end subroutine psi_sovrl_restrr1 -subroutine psi_sovrl_restrr2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_sovrl_restrr2 + module subroutine psi_sovrl_restrr2(x,xs,desc_a,info) - implicit none + implicit none - real(psb_spk_), intent(inout) :: x(:,:) - real(psb_spk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + real(psb_spk_), intent(inout) :: x(:,:) + real(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err - name='psi_sovrl_restrr2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif + name='psi_sovrl_restrr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif - if (size(x,2) /= size(xs,2)) then - info = psb_err_internal_error_ - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif + if (size(x,2) /= size(xs,2)) then + info = psb_err_internal_error_ + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif - isz = size(desc_a%ovrlap_elem,1) + isz = size(desc_a%ovrlap_elem,1) - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_sovrl_restrr2 + return + end subroutine psi_sovrl_restrr2 +end submodule psi_s_ovrl_restr_a_impl diff --git a/base/comm/internals/psi_sovrl_save.f90 b/base/comm/internals/psi_sovrl_save.f90 index cb058fe4..cd259f72 100644 --- a/base/comm/internals/psi_sovrl_save.f90 +++ b/base/comm/internals/psi_sovrl_save.f90 @@ -34,103 +34,101 @@ ! for the transpose matrix-vector product when there is a nonempty overlap. ! ! -subroutine psi_sovrl_save_vect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_sovrl_save_vect - use psb_realloc_mod - use psb_s_base_vect_mod - - implicit none - - class(psb_s_base_vect_type) :: x - real(psb_spk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_dovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) - - call psb_erractionrestore(err_act) - return +submodule (psi_s_comm_v_mod) psi_s_ovrl_save_v_impl + use psb_base_mod +contains + module subroutine psi_sovrl_save_vect(x,xs,desc_a,info) + + implicit none + + class(psb_s_base_vect_type) :: x + real(psb_spk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_sovrl_save_vect - -subroutine psi_sovrl_save_multivect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_sovrl_save_multivect - use psb_realloc_mod - use psb_s_base_vect_mod - - implicit none - - class(psb_s_base_multivect_type) :: x - real(psb_spk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, nc - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_dovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = x%get_ncols() - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_sovrl_save_vect + + module subroutine psi_sovrl_save_multivect(x,xs,desc_a,info) + + implicit none + + class(psb_s_base_multivect_type) :: x + real(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, nc + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_sovrl_save_multivect + return + end subroutine psi_sovrl_save_multivect +end submodule psi_s_ovrl_save_v_impl diff --git a/base/comm/internals/psi_sovrl_save_a.f90 b/base/comm/internals/psi_sovrl_save_a.f90 index e2b57541..aa3468e0 100644 --- a/base/comm/internals/psi_sovrl_save_a.f90 +++ b/base/comm/internals/psi_sovrl_save_a.f90 @@ -34,108 +34,104 @@ ! These subroutines save the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap. ! -subroutine psi_sovrl_saver1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_sovrl_saver1 - - use psb_realloc_mod - - implicit none - - real(psb_spk_), intent(inout) :: x(:) - real(psb_spk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_sovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return +submodule (psi_s_comm_a_mod) psi_s_ovrl_save_a_impl + use psb_base_mod +contains + module subroutine psi_sovrl_saver1(x,xs,desc_a,info) + implicit none + + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_sovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_sovrl_saver1 - - -subroutine psi_sovrl_saver2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_sovrl_saver2 - - use psb_realloc_mod - - implicit none - - real(psb_spk_), intent(inout) :: x(:,:) - real(psb_spk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_sovrl_saver2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_sovrl_saver1 + + + module subroutine psi_sovrl_saver2(x,xs,desc_a,info) + implicit none + + real(psb_spk_), intent(inout) :: x(:,:) + real(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_sovrl_saver2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_sovrl_saver2 + return + end subroutine psi_sovrl_saver2 +end submodule psi_s_ovrl_save_a_impl diff --git a/base/comm/internals/psi_sovrl_upd.f90 b/base/comm/internals/psi_sovrl_upd.f90 index ba3a9f41..2ee13aa6 100644 --- a/base/comm/internals/psi_sovrl_upd.f90 +++ b/base/comm/internals/psi_sovrl_upd.f90 @@ -36,169 +36,167 @@ ! ! ! -subroutine psi_sovrl_upd_vect(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_sovrl_upd_vect - use psb_realloc_mod - use psb_s_base_vect_mod - - implicit none - - class(psb_s_base_vect_type) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - real(psb_spk_), allocatable :: xs(:) - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, nx, ndm - integer(psb_ipk_) :: err_act, i, idx - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - - name='psi_sovrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - nx = size(desc_a%ovrlap_elem,1) - call psb_realloc(nx,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_Dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - if (update /= psb_sum_) then - call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) - ! switch on update type - - select case (update) - case(psb_square_root_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i) = xs(i)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i) = xs(i)/real(ndm) - end do - case(psb_setzero_) - do i=1,nx - if (me /= desc_a%ovrlap_elem(i,3))& - & xs(i) = szero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) +submodule (psi_s_comm_v_mod) psi_s_ovrl_upd_v_impl + use psb_base_mod +contains + module subroutine psi_sovrl_upd_vect(x,desc_a,update,info) + + implicit none + + class(psb_s_base_vect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + real(psb_spk_), allocatable :: xs(:) + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, nx, ndm + integer(psb_ipk_) :: err_act, i, idx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_sovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end select - call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,szero) - end if - - call psb_erractionrestore(err_act) - return + endif + nx = size(desc_a%ovrlap_elem,1) + call psb_realloc(nx,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i) = szero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,szero) + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_sovrl_upd_vect - -subroutine psi_sovrl_upd_multivect(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_sovrl_upd_multivect - use psb_realloc_mod - use psb_s_base_vect_mod - - implicit none - - class(psb_s_base_multivect_type) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - real(psb_spk_), allocatable :: xs(:,:) - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, ndm, nx, nc - integer(psb_ipk_) :: err_act, i, idx - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - - name='psi_sovrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - nx = size(desc_a%ovrlap_elem,1) - nc = x%get_ncols() - call psb_realloc(nx,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_Dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - if (update /= psb_sum_) then - call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) - ! switch on update type - - select case (update) - case(psb_square_root_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i,:) = xs(i,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i,:) = xs(i,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,nx - if (me /= desc_a%ovrlap_elem(i,3))& - & xs(i,:) = szero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) + return + end subroutine psi_sovrl_upd_vect + + module subroutine psi_sovrl_upd_multivect(x,desc_a,update,info) + + implicit none + + class(psb_s_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + real(psb_spk_), allocatable :: xs(:,:) + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, ndm, nx, nc + integer(psb_ipk_) :: err_act, i, idx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_sovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end select - call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,szero) - end if - - call psb_erractionrestore(err_act) - return + endif + nx = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(nx,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i,:) = szero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,szero) + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_sovrl_upd_multivect + return + end subroutine psi_sovrl_upd_multivect +end submodule psi_s_ovrl_upd_v_impl diff --git a/base/comm/internals/psi_sovrl_upd_a.f90 b/base/comm/internals/psi_sovrl_upd_a.f90 index 4387492d..64d85631 100644 --- a/base/comm/internals/psi_sovrl_upd_a.f90 +++ b/base/comm/internals/psi_sovrl_upd_a.f90 @@ -32,143 +32,143 @@ ! Subroutine: psi_sovrl_update ! These subroutines update the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap, -! or for the application of Additive Schwarz preconditioners. +! or for the application of Additive Schwarz preconditioners. ! ! -subroutine psi_sovrl_updr1(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_sovrl_updr1 - - implicit none - - real(psb_spk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_sovrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = szero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return +submodule (psi_s_comm_a_mod) psi_s_ovrl_upd_a_impl + use psb_base_mod +contains + module subroutine psi_sovrl_updr1(x,desc_a,update,info) + implicit none + + real(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_sovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = szero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_sovrl_updr1 - -subroutine psi_sovrl_updr2(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_sovrl_updr2 - - implicit none - - real(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_sovrl_updr2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = szero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_sovrl_updr1 + + module subroutine psi_sovrl_updr2(x,desc_a,update,info) + implicit none + + real(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_sovrl_updr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = szero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_sovrl_updr2 + return + end subroutine psi_sovrl_updr2 +end submodule psi_s_ovrl_upd_a_impl diff --git a/base/comm/internals/psi_sswapdata.F90 b/base/comm/internals/psi_sswapdata.F90 index 5d1180d3..bd3e6992 100644 --- a/base/comm/internals/psi_sswapdata.F90 +++ b/base/comm/internals/psi_sswapdata.F90 @@ -89,676 +89,659 @@ ! ! ! -subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data) +submodule (psi_s_comm_v_mod) psi_s_swapdata_impl + use psb_base_mod +contains + subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_sswapdata_vect - use psb_s_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_vect_type) :: y - real(psb_spk_) :: beta - real(psb_spk_), target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_vect_type) :: y + real(psb_spk_) :: beta + real(psb_spk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) return -end subroutine psi_sswapdata_vect +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_sswapdata_vect + + + ! + ! + ! Subroutine: psi_sswap_vidx_vect + ! Data exchange among processes. + ! + ! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods + ! of vectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_sswap_vidx_vect(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_sswap_vidx_vect -! Data exchange among processes. -! -! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods -! of vectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_sswap_vidx_vect(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_sswap_vidx_vect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_s_base_vect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_vect_type) :: y - real(psb_spk_) :: beta - real(psb_spk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, nesd, nerv - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, n - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_vect_type) :: y + real(psb_spk_) :: beta + real(psb_spk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),& + & iret, nesd, nerv + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + rcv_pt = 1+pnti+psb_n_elem_recv_ + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_real_swap_tag + call mpi_irecv(y%combuf(rcv_pt),nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + idx_pt = snd_pt + call y%gth(idx_pt,nesd,idx) + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_real_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - p2ptag = psb_real_swap_tag - call mpi_irecv(y%combuf(rcv_pt),nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - pnti = pnti + nerv + nesd + 3 - end do - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - idx_pt = snd_pt - call y%gth(idx_pt,nesd,idx) - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - p2ptag = psb_real_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if ((nesd>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(snd_pt),nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - p2ptag = psb_real_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (proc_to_comm /= me)then - if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_real_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) + call y%sct(rcv_pt,nerv,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(rcv_pt:rcv_pt+nerv-1) - call y%sct(rcv_pt,nerv,idx,beta) - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for everybody, clean up - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_sswap_vidx_vect - -! -! -! Subroutine: psi_sswapdata_multivect -! Data exchange among processes. -! -! Takes care of Y an encaspulated multivector. -! -! -subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_sswapdata_multivect - use psb_s_base_multivect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_sswap_vidx_vect + + ! + ! + ! Subroutine: psi_sswapdata_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_multivect_type) :: y - real(psb_spk_) :: beta - real(psb_spk_), target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type) :: y + real(psb_spk_) :: beta + real(psb_spk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) return -end subroutine psi_sswapdata_multivect +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_sswapdata_multivect + + + ! + ! + ! Subroutine: psi_sswap_vidx_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods + ! of multivectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_sswap_vidx_multivect(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_sswap_vidx_multivect -! Data exchange among processes. -! -! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods -! of multivectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_sswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_sswap_vidx_multivect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_s_base_multivect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_multivect_type) :: y - real(psb_spk_) :: beta - real(psb_spk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n = y%get_ncols() - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type) :: y + real(psb_spk_) :: beta + real(psb_spk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + n = y%get_ncols() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_real_swap_tag + call mpi_irecv(y%combuf(rcv_pt),n*nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call y%gth(idx_pt,snd_pt,nesd,idx) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait for device + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_real_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),n*nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - p2ptag = psb_real_swap_tag - call mpi_irecv(y%combuf(rcv_pt),n*nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call y%gth(idx_pt,snd_pt,nesd,idx) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait for device - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_real_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - if ((nesd>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(snd_pt),n*nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_real_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm /= me)then - if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_real_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+n*nerv-1) + call y%sct(idx_pt,rcv_pt,nerv,idx,beta) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(rcv_pt:rcv_pt+n*nerv-1) - call y%sct(idx_pt,rcv_pt,nerv,idx,beta) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for com, cleanup comid - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_sswap_vidx_multivect + return + end subroutine psi_sswap_vidx_multivect +end submodule psi_s_swapdata_impl diff --git a/base/comm/internals/psi_sswapdata_a.F90 b/base/comm/internals/psi_sswapdata_a.F90 index c85062b7..23da8224 100644 --- a/base/comm/internals/psi_sswapdata_a.F90 +++ b/base/comm/internals/psi_sswapdata_a.F90 @@ -84,912 +84,899 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) +submodule (psi_s_comm_a_mod) psi_s_swapdata_a_impl + use psb_base_mod +contains + module subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_sswapdatam - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:,:), beta - real(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info +real(psb_spk_) :: y(:,:), beta +real(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_sswapdatam + end subroutine psi_sswapdatam -subroutine psi_sswapidxm(ctxt,icomm,flag,n,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) + module subroutine psi_sswapidxm(ctxt,flag,n,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) - use psi_mod, psb_protect_name => psi_sswapidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:,:), beta - real(psb_spk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - - integer(psb_mpk_) :: np, me, nesd, nerv - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info +real(psb_spk_) :: y(:,:), beta +real(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + + integer(psb_mpk_) :: np, me, nesd, nerv + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_mpk_) :: icomm + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + +real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if - ! prepare info for communications + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + end if - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_r_spk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_r_spk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_real_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_r_spk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_r_spk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_real_swap_tag + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_real_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*)& + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_sync) then - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + else if (swap_send) then - if (proc_to_comm < me) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - end do + end if + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then + end if - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_real_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_real_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),n*nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),n*nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,iret) - end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_real_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*)& - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_sswapidxm + end subroutine psi_sswapidxm + + ! + ! + ! Subroutine: psi_sswapdatav + ! Implements the data exchange among processes. Essentially this is doing + ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but + ! it is capable of pruning empty exchanges, which are very likely in out + ! application environment. All the variants have the same structure + ! In all these subroutines X may be: I Integer + ! S real(psb_spk_) + ! D real(psb_dpk_) + ! C complex(psb_spk_) + ! Z complex(psb_dpk_) + ! Basically the operation is as follows: on each process, we identify + ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); + ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y + ! but only on the elements involved in the UNPACK operation. + ! Thus: for halo data exchange, the receive section is confined in the + ! halo indices, and BETA=0, whereas for overlap exchange the receive section + ! is scattered in the owned indices, and BETA=1. + ! The first routine picks the desired exchange index list and passes it to the second. + ! + ! Arguments: + ! flag - integer Choose the algorithm for data exchange: + ! this is chosen through bit fields. + ! 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 + ! if (swap_mpi): use underlying MPI_ALLTOALLV. + ! if (swap_sync): use PSB_SND and PSB_RCV in + ! synchronized pairs + ! if (swap_send .and. swap_recv): use mpi_irecv + ! and mpi_send + ! if (swap_send): use psb_snd (but need another + ! call with swap_recv to complete) + ! if (swap_recv): use psb_rcv (completing a + ! previous call with swap_send) + ! + ! + ! n - integer Number of columns in Y + ! beta - real Choose overwrite or sum. + ! y(:) - real The data area + ! desc_a - type(psb_desc_type). The communication descriptor. + ! work(:) - real Buffer space. If not sufficient, will do + ! our own internal allocation. + ! info - integer. return code. + ! data - integer which list is to be used to exchange data + ! default psb_comm_halo_ + ! psb_comm_halo_ use halo_index + ! psb_comm_ext_ use ext_index + ! psb_comm_ovrl_ use ovrl_index + ! psb_comm_mov_ use ovr_mst_idx + ! + ! + module subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) -! -! -! Subroutine: psi_sswapdatav -! Implements the data exchange among processes. Essentially this is doing -! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! The first routine picks the desired exchange index list and passes it to the second. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! 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 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - real Choose overwrite or sum. -! y(:) - real The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - real Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_sswapdatav - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:), beta - real(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif - return -end subroutine psi_sswapdatav + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if -! -! -! Subroutine: psi_sswapdataidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_sswapidxv(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) + call psi_swapdata(ctxt,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) - use psi_mod, psb_protect_name => psi_sswapidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_sswapdatav + + + ! + ! + ! Subroutine: psi_sswapdataidxv + ! Does the data exchange among processes. + ! + ! The real workhorse: the outer routines will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_sswapidxv(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psb_error_mod + use psb_desc_mod + use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:), beta - real(psb_spk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + integer(psb_mpk_) :: icomm + logical, parameter :: usersend=.false. + + real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications + ! prepare info for communications - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - end do + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - end if - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_r_spk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_r_spk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. end if - else if (swap_sync) then - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + if (do_send) then - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_r_spk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_r_spk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_real_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_real_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_real_swap_tag - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_real_swap_tag + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_real_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,iret) + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) end if + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_real_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_sswapidxv + end subroutine psi_sswapidxv +end submodule psi_s_swapdata_a_impl diff --git a/base/comm/internals/psi_sswaptran.F90 b/base/comm/internals/psi_sswaptran.F90 index 24c75978..afb208e8 100644 --- a/base/comm/internals/psi_sswaptran.F90 +++ b/base/comm/internals/psi_sswaptran.F90 @@ -91,418 +91,406 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data) +submodule (psi_s_comm_v_mod) psi_s_swaptran_impl + use psb_base_mod +contains + module subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_sswaptran_vect - use psb_s_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_vect_type) :: y - real(psb_spk_) :: beta - real(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_vect_type) :: y + real(psb_spk_) :: beta + real(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_sswaptran_vect + end subroutine psi_sswaptran_vect + + ! + ! + ! Subroutine: psi_stran_vidx_vect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated vector. Relies on the gather/scatter methods + ! of vectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_stran_vidx_vect(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_stran_vidx_vect -! Data exchange among processes. -! -! Takes care of Y an encapsulated vector. Relies on the gather/scatter methods -! of vectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_stran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_stran_vidx_vect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_s_base_vect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_vect_type) :: y - real(psb_spk_) :: beta - real(psb_spk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - p2ptag = psb_real_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - call mpi_irecv(y%combuf(snd_pt),nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - idx_pt = rcv_pt - call y%gth(idx_pt,nerv,idx) - - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - p2ptag = psb_real_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if ((nerv>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(rcv_pt),nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_vect_type) :: y + real(psb_spk_) :: beta + real(psb_spk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + p2ptag = psb_real_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + call mpi_irecv(y%combuf(snd_pt),nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + idx_pt = rcv_pt + call y%gth(idx_pt,nerv,idx) + + pnti = pnti + nerv + nesd + 3 + end do - pnti = pnti + nerv + nesd + 3 - end do - end if + ! + ! Then wait + ! + call y%device_wait() - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... + if (debug) write(*,*) me,' isend' ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_real_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - p2ptag = psb_real_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (proc_to_comm /= me)then - if (nerv>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_real_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+nesd-1) + call y%sct(snd_pt,nesd,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(snd_pt:snd_pt+nesd-1) - call y%sct(snd_pt,nesd,idx,beta) - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for everybody, clean up - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return + return -end subroutine psi_stran_vidx_vect + end subroutine psi_stran_vidx_vect -! -! -! -! -! Subroutine: psi_sswaptran_multivect -! Data exchange among processes. -! -! Takes care of Y an encaspulated multivector. -! -! -subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data) + ! + ! + ! + ! + ! Subroutine: psi_sswaptran_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_sswaptran_multivect - use psb_s_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_multivect_type) :: y - real(psb_spk_) :: beta - real(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type) :: y + real(psb_spk_) :: beta + real(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) @@ -510,273 +498,266 @@ subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data) end subroutine psi_sswaptran_multivect -! -! -! Subroutine: psi_stran_vidx_multivect -! Data exchange among processes. -! -! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods -! of multivectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_stran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_stran_vidx_multivect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_s_base_multivect_mod + ! + ! + ! Subroutine: psi_stran_vidx_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods + ! of multivectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_stran_vidx_multivect(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_s_base_multivect_type) :: y - real(psb_spk_) :: beta - real(psb_spk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n = y%get_ncols() - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_s_base_multivect_type) :: y + real(psb_spk_) :: beta + real(psb_spk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + n = y%get_ncols() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_real_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt + call mpi_irecv(y%combuf(snd_pt),n*nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call y%gth(idx_pt,rcv_pt,nerv,idx) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait for device + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_real_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),n*nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_real_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt - call mpi_irecv(y%combuf(snd_pt),n*nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call y%gth(idx_pt,rcv_pt,nerv,idx) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait for device - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_real_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - if ((nerv>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(rcv_pt),n*nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_real_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm /= me)then - if (nerv>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_real_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(snd_pt:snd_pt+n*nesd-1) - call y%sct(idx_pt,snd_pt,nesd,idx,beta) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! - ! Waited for com, cleanup comid - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if (debug) write(*,*) me,' done' - end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+n*nesd-1) + call y%sct(idx_pt,snd_pt,nesd,idx,beta) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - call psb_erractionrestore(err_act) - return + ! + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null -9999 call psb_error_handler(ctxt,err_act) + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if - return -end subroutine psi_stran_vidx_multivect + call psb_erractionrestore(err_act) + return +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_stran_vidx_multivect +end submodule psi_s_swaptran_impl diff --git a/base/comm/internals/psi_sswaptran_a.F90 b/base/comm/internals/psi_sswaptran_a.F90 index 749d1f01..4987450e 100644 --- a/base/comm/internals/psi_sswaptran_a.F90 +++ b/base/comm/internals/psi_sswaptran_a.F90 @@ -88,922 +88,909 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) +submodule (psi_s_comm_a_mod) psi_s_swaptran_a_impl + use psb_base_mod +contains + module subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_sswaptranm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:,:), beta - real(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, err_act, totxch, data_ - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, err_act, totxch, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return -end subroutine psi_sswaptranm -subroutine psi_stranidxm(ctxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) +9999 call psb_error_handler(ctxt,err_act) - use psi_mod, psb_protect_name => psi_stranidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_sswaptranm + + module subroutine psi_stranidxm(ctxt,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:,:), beta - real(psb_spk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + integer(psb_mpk_) :: icomm + logical, parameter :: usersend=.false. + + real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if - ! prepare info for communications + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + if (do_send) then - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd + call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 end if - albf=.true. - end if - if (do_send) then - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) + ! Case SWAP_MPI + if (swap_mpi) then - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_r_spk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_r_spk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if - end if + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_real_swap_tag + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_real_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - ! Case SWAP_MPI - if (swap_mpi) then + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_r_spk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_r_spk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_real_swap_tag - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send',& + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_real_swap_tag - call mpi_irecv(sndbuf(snd_pt),n*nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + else if (swap_send) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + else if (swap_recv) then - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_real_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,iret) - end if + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 + end if - end do + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_real_swap_tag + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send',& - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_stranidxm -! -! -! Subroutine: psi_sswaptranv -! Implements the data exchange among processes. This is similar to Xswapdata, but -! the list is read "in reverse", i.e. indices that are normally SENT are used -! for the RECEIVE part and vice-versa. This is the basic data exchange operation -! for doing the product of a sparse matrix by a vector. -! Essentially this is doing a variable all-to-all data exchange -! (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! The first routine picks the desired exchange index list and passes it to the second. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! 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 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - real Choose overwrite or sum. -! y(:) - real The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - real Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_sswaptranv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + end subroutine psi_stranidxm + ! + ! + ! Subroutine: psi_sswaptranv + ! Implements the data exchange among processes. This is similar to Xswapdata, but + ! the list is read "in reverse", i.e. indices that are normally SENT are used + ! for the RECEIVE part and vice-versa. This is the basic data exchange operation + ! for doing the product of a sparse matrix by a vector. + ! Essentially this is doing a variable all-to-all data exchange + ! (ALLTOALLV in MPI parlance), but + ! it is capable of pruning empty exchanges, which are very likely in out + ! application environment. All the variants have the same structure + ! In all these subroutines X may be: I Integer + ! S real(psb_spk_) + ! D real(psb_dpk_) + ! C complex(psb_spk_) + ! Z complex(psb_dpk_) + ! Basically the operation is as follows: on each process, we identify + ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); + ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y + ! but only on the elements involved in the UNPACK operation. + ! Thus: for halo data exchange, the receive section is confined in the + ! halo indices, and BETA=0, whereas for overlap exchange the receive section + ! is scattered in the owned indices, and BETA=1. + ! The first routine picks the desired exchange index list and passes it to the second. + ! + ! Arguments: + ! flag - integer Choose the algorithm for data exchange: + ! this is chosen through bit fields. + ! 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 + ! if (swap_mpi): use underlying MPI_ALLTOALLV. + ! if (swap_sync): use PSB_SND and PSB_RCV in + ! synchronized pairs + ! if (swap_send .and. swap_recv): use mpi_irecv + ! and mpi_send + ! if (swap_send): use psb_snd (but need another + ! call with swap_recv to complete) + ! if (swap_recv): use psb_rcv (completing a + ! previous call with swap_send) + ! + ! + ! n - integer Number of columns in Y + ! beta - real Choose overwrite or sum. + ! y(:) - real The data area + ! desc_a - type(psb_desc_type). The communication descriptor. + ! work(:) - real Buffer space. If not sufficient, will do + ! our own internal allocation. + ! info - integer. return code. + ! data - integer which list is to be used to exchange data + ! default psb_comm_halo_ + ! psb_comm_halo_ use halo_index + ! psb_comm_ext_ use ext_index + ! psb_comm_ovrl_ use ovrl_index + ! psb_comm_mov_ use ovr_mst_idx + ! + ! + module subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:), beta - real(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif - return -end subroutine psi_sswaptranv + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if -! -! -! Subroutine: psi_stranidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_stranidxv(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) + call psi_swaptran(ctxt,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 - use psi_mod, psb_protect_name => psi_stranidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_sswaptranv + + + ! + ! + ! Subroutine: psi_stranidxv + ! Does the data exchange among processes. + ! + ! The real workhorse: the outer routines will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_stranidxv(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:), beta - real(psb_spk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_mpk_) :: icomm + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications + ! prepare info for communications - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - end do + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - end if - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_r_spk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_r_spk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - else if (swap_sync) then + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_r_spk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_r_spk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_real_swap_tag + call mpi_irecv(sndbuf(snd_pt),nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_real_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm < me) then + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_real_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_real_swap_tag - call mpi_irecv(sndbuf(snd_pt),nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + end if - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_real_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag, icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag, icomm,iret) - end if + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_real_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_stranidxv + end subroutine psi_stranidxv +end submodule psi_s_swaptran_a_impl diff --git a/base/comm/internals/psi_zovrl_restr.f90 b/base/comm/internals/psi_zovrl_restr.f90 index 7fe94aa6..668d1d49 100644 --- a/base/comm/internals/psi_zovrl_restr.f90 +++ b/base/comm/internals/psi_zovrl_restr.f90 @@ -35,90 +35,90 @@ ! ! ! -subroutine psi_zovrl_restr_vect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_zovrl_restr_vect - use psb_z_base_vect_mod - - implicit none - - class(psb_z_base_vect_type) :: x - complex(psb_dpk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_zovrl_restr_vect' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,zzero) - - call psb_erractionrestore(err_act) - return +submodule (psi_z_comm_v_mod) psi_z_ovrl_restr_v_impl + use psb_base_mod +contains + module subroutine psi_zovrl_restr_vect(x,xs,desc_a,info) + + implicit none + + class(psb_z_base_vect_type) :: x + complex(psb_dpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_zovrl_restr_vect' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,zzero) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_zovrl_restr_vect + return + end subroutine psi_zovrl_restr_vect -subroutine psi_zovrl_restr_multivect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_zovrl_restr_multivect - use psb_z_base_vect_mod + module subroutine psi_zovrl_restr_multivect(x,xs,desc_a,info) - implicit none + implicit none - class(psb_z_base_multivect_type) :: x - complex(psb_dpk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type) :: x + complex(psb_dpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz,nc - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz,nc + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err - name='psi_zovrl_restr_mv' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif + name='psi_zovrl_restr_mv' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif - isz = size(desc_a%ovrlap_elem,1) - call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,zzero) + isz = size(desc_a%ovrlap_elem,1) + call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,zzero) - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_zovrl_restr_multivect + return + end subroutine psi_zovrl_restr_multivect +end submodule psi_z_ovrl_restr_v_impl diff --git a/base/comm/internals/psi_zovrl_restr_a.f90 b/base/comm/internals/psi_zovrl_restr_a.f90 index a823b73d..a8347008 100644 --- a/base/comm/internals/psi_zovrl_restr_a.f90 +++ b/base/comm/internals/psi_zovrl_restr_a.f90 @@ -34,98 +34,100 @@ ! for the transpose matrix-vector product when there is a nonempty overlap. ! ! -subroutine psi_zovrl_restrr1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_zovrl_restrr1 - - implicit none - - complex(psb_dpk_), intent(inout) :: x(:) - complex(psb_dpk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_zovrl_restrr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return +submodule (psi_z_comm_a_mod) psi_z_ovrl_restr_a_impl + use psb_base_mod +contains + module subroutine psi_zovrl_restrr1(x,xs,desc_a,info) + + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + complex(psb_dpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_zovrl_restrr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_zovrl_restrr1 + return + end subroutine psi_zovrl_restrr1 -subroutine psi_zovrl_restrr2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_zovrl_restrr2 + module subroutine psi_zovrl_restrr2(x,xs,desc_a,info) - implicit none + implicit none - complex(psb_dpk_), intent(inout) :: x(:,:) - complex(psb_dpk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), intent(inout) :: x(:,:) + complex(psb_dpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err - name='psi_zovrl_restrr2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif + name='psi_zovrl_restrr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif - if (size(x,2) /= size(xs,2)) then - info = psb_err_internal_error_ - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif + if (size(x,2) /= size(xs,2)) then + info = psb_err_internal_error_ + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif - isz = size(desc_a%ovrlap_elem,1) + isz = size(desc_a%ovrlap_elem,1) - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_zovrl_restrr2 + return + end subroutine psi_zovrl_restrr2 +end submodule psi_z_ovrl_restr_a_impl diff --git a/base/comm/internals/psi_zovrl_save.f90 b/base/comm/internals/psi_zovrl_save.f90 index 841dec1d..24f4011a 100644 --- a/base/comm/internals/psi_zovrl_save.f90 +++ b/base/comm/internals/psi_zovrl_save.f90 @@ -34,103 +34,101 @@ ! for the transpose matrix-vector product when there is a nonempty overlap. ! ! -subroutine psi_zovrl_save_vect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_zovrl_save_vect - use psb_realloc_mod - use psb_z_base_vect_mod - - implicit none - - class(psb_z_base_vect_type) :: x - complex(psb_dpk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_dovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) - - call psb_erractionrestore(err_act) - return +submodule (psi_z_comm_v_mod) psi_z_ovrl_save_v_impl + use psb_base_mod +contains + module subroutine psi_zovrl_save_vect(x,xs,desc_a,info) + + implicit none + + class(psb_z_base_vect_type) :: x + complex(psb_dpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_zovrl_save_vect - -subroutine psi_zovrl_save_multivect(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_zovrl_save_multivect - use psb_realloc_mod - use psb_z_base_vect_mod - - implicit none - - class(psb_z_base_multivect_type) :: x - complex(psb_dpk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, nc - integer(psb_ipk_) :: err_act, i, idx - character(len=20) :: name, ch_err - - name='psi_dovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = x%get_ncols() - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_zovrl_save_vect + + module subroutine psi_zovrl_save_multivect(x,xs,desc_a,info) + + implicit none + + class(psb_z_base_multivect_type) :: x + complex(psb_dpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, nc + integer(psb_ipk_) :: err_act, i, idx + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_zovrl_save_multivect + return + end subroutine psi_zovrl_save_multivect +end submodule psi_z_ovrl_save_v_impl diff --git a/base/comm/internals/psi_zovrl_save_a.f90 b/base/comm/internals/psi_zovrl_save_a.f90 index f2c09ee8..c5cb81f7 100644 --- a/base/comm/internals/psi_zovrl_save_a.f90 +++ b/base/comm/internals/psi_zovrl_save_a.f90 @@ -34,108 +34,104 @@ ! These subroutines save the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap. ! -subroutine psi_zovrl_saver1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_zovrl_saver1 - - use psb_realloc_mod - - implicit none - - complex(psb_dpk_), intent(inout) :: x(:) - complex(psb_dpk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_zovrl_saver1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return +submodule (psi_z_comm_a_mod) psi_z_ovrl_save_a_impl + use psb_base_mod +contains + module subroutine psi_zovrl_saver1(x,xs,desc_a,info) + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + complex(psb_dpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_zovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_zovrl_saver1 - - -subroutine psi_zovrl_saver2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_zovrl_saver2 - - use psb_realloc_mod - - implicit none - - complex(psb_dpk_), intent(inout) :: x(:,:) - complex(psb_dpk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_zovrl_saver2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_zovrl_saver1 + + + module subroutine psi_zovrl_saver2(x,xs,desc_a,info) + implicit none + + complex(psb_dpk_), intent(inout) :: x(:,:) + complex(psb_dpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_zovrl_saver2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_zovrl_saver2 + return + end subroutine psi_zovrl_saver2 +end submodule psi_z_ovrl_save_a_impl diff --git a/base/comm/internals/psi_zovrl_upd.f90 b/base/comm/internals/psi_zovrl_upd.f90 index 7a3bccf2..b6a23f09 100644 --- a/base/comm/internals/psi_zovrl_upd.f90 +++ b/base/comm/internals/psi_zovrl_upd.f90 @@ -36,169 +36,167 @@ ! ! ! -subroutine psi_zovrl_upd_vect(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_zovrl_upd_vect - use psb_realloc_mod - use psb_z_base_vect_mod - - implicit none - - class(psb_z_base_vect_type) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - complex(psb_dpk_), allocatable :: xs(:) - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, nx, ndm - integer(psb_ipk_) :: err_act, i, idx - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - - name='psi_zovrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - nx = size(desc_a%ovrlap_elem,1) - call psb_realloc(nx,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_Dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - if (update /= psb_sum_) then - call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) - ! switch on update type - - select case (update) - case(psb_square_root_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i) = xs(i)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i) = xs(i)/real(ndm) - end do - case(psb_setzero_) - do i=1,nx - if (me /= desc_a%ovrlap_elem(i,3))& - & xs(i) = zzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) +submodule (psi_z_comm_v_mod) psi_z_ovrl_upd_v_impl + use psb_base_mod +contains + module subroutine psi_zovrl_upd_vect(x,desc_a,update,info) + + implicit none + + class(psb_z_base_vect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + complex(psb_dpk_), allocatable :: xs(:) + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, nx, ndm + integer(psb_ipk_) :: err_act, i, idx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_zovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end select - call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,zzero) - end if - - call psb_erractionrestore(err_act) - return + endif + nx = size(desc_a%ovrlap_elem,1) + call psb_realloc(nx,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i) = zzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,zzero) + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_zovrl_upd_vect - -subroutine psi_zovrl_upd_multivect(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_zovrl_upd_multivect - use psb_realloc_mod - use psb_z_base_vect_mod - - implicit none - - class(psb_z_base_multivect_type) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - complex(psb_dpk_), allocatable :: xs(:,:) - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: np, me, isz, ndm, nx, nc - integer(psb_ipk_) :: err_act, i, idx - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - - name='psi_zovrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - nx = size(desc_a%ovrlap_elem,1) - nc = x%get_ncols() - call psb_realloc(nx,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_Dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - if (update /= psb_sum_) then - call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) - ! switch on update type - - select case (update) - case(psb_square_root_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i,:) = xs(i,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,nx - ndm = desc_a%ovrlap_elem(i,2) - xs(i,:) = xs(i,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,nx - if (me /= desc_a%ovrlap_elem(i,3))& - & xs(i,:) = zzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) + return + end subroutine psi_zovrl_upd_vect + + module subroutine psi_zovrl_upd_multivect(x,desc_a,update,info) + + implicit none + + class(psb_z_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + complex(psb_dpk_), allocatable :: xs(:,:) + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me, isz, ndm, nx, nc + integer(psb_ipk_) :: err_act, i, idx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_zovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end select - call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,zzero) - end if - - call psb_erractionrestore(err_act) - return + endif + nx = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(nx,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i,:) = zzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,zzero) + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_zovrl_upd_multivect + return + end subroutine psi_zovrl_upd_multivect +end submodule psi_z_ovrl_upd_v_impl diff --git a/base/comm/internals/psi_zovrl_upd_a.f90 b/base/comm/internals/psi_zovrl_upd_a.f90 index 658bd317..7bfd56b1 100644 --- a/base/comm/internals/psi_zovrl_upd_a.f90 +++ b/base/comm/internals/psi_zovrl_upd_a.f90 @@ -32,143 +32,143 @@ ! Subroutine: psi_zovrl_update ! These subroutines update the overlap region of a vector; they are used ! for the transpose matrix-vector product when there is a nonempty overlap, -! or for the application of Additive Schwarz preconditioners. +! or for the application of Additive Schwarz preconditioners. ! ! -subroutine psi_zovrl_updr1(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_zovrl_updr1 - - implicit none - - complex(psb_dpk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_zovrl_updr1' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = zzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return +submodule (psi_z_comm_a_mod) psi_z_ovrl_upd_a_impl + use psb_base_mod +contains + module subroutine psi_zovrl_updr1(x,desc_a,update,info) + implicit none + + complex(psb_dpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_zovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = zzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_zovrl_updr1 - -subroutine psi_zovrl_updr2(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_zovrl_updr2 - - implicit none - - complex(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_zovrl_updr2' - info = psb_success_ - call psb_erractionsave(err_act) - if (psb_errstatus_fatal()) then - info = psb_err_internal_error_ ; goto 9999 - end if - ctxt = desc_a%get_context() - call psb_info(ctxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = zzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return + return + end subroutine psi_zovrl_updr1 + + module subroutine psi_zovrl_updr2(x,desc_a,update,info) + implicit none + + complex(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_zovrl_updr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ctxt = desc_a%get_context() + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = zzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_zovrl_updr2 + return + end subroutine psi_zovrl_updr2 +end submodule psi_z_ovrl_upd_a_impl diff --git a/base/comm/internals/psi_zswapdata.F90 b/base/comm/internals/psi_zswapdata.F90 index 3716fba6..93fc1edf 100644 --- a/base/comm/internals/psi_zswapdata.F90 +++ b/base/comm/internals/psi_zswapdata.F90 @@ -89,676 +89,659 @@ ! ! ! -subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data) +submodule (psi_z_comm_v_mod) psi_z_swapdata_impl + use psb_base_mod +contains + subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_zswapdata_vect - use psb_z_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_vect_type) :: y - complex(psb_dpk_) :: beta - complex(psb_dpk_), target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_vect_type) :: y + complex(psb_dpk_) :: beta + complex(psb_dpk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) return -end subroutine psi_zswapdata_vect +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_zswapdata_vect + + + ! + ! + ! Subroutine: psi_zswap_vidx_vect + ! Data exchange among processes. + ! + ! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods + ! of vectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_zswap_vidx_vect(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_zswap_vidx_vect -! Data exchange among processes. -! -! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods -! of vectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_zswap_vidx_vect(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_zswap_vidx_vect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_z_base_vect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_vect_type) :: y - complex(psb_dpk_) :: beta - complex(psb_dpk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),& - & iret, nesd, nerv - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, n - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_vect_type) :: y + complex(psb_dpk_) :: beta + complex(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size),& + & iret, nesd, nerv + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + rcv_pt = 1+pnti+psb_n_elem_recv_ + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_dcomplex_swap_tag + call mpi_irecv(y%combuf(rcv_pt),nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + idx_pt = snd_pt + call y%gth(idx_pt,nesd,idx) + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_dcomplex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - p2ptag = psb_dcomplex_swap_tag - call mpi_irecv(y%combuf(rcv_pt),nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - pnti = pnti + nerv + nesd + 3 - end do - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - idx_pt = snd_pt - call y%gth(idx_pt,nesd,idx) - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - p2ptag = psb_dcomplex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if ((nesd>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(snd_pt),nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - p2ptag = psb_dcomplex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (proc_to_comm /= me)then - if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_dcomplex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) + call y%sct(rcv_pt,nerv,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(rcv_pt:rcv_pt+nerv-1) - call y%sct(rcv_pt,nerv,idx,beta) - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for everybody, clean up - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_zswap_vidx_vect - -! -! -! Subroutine: psi_zswapdata_multivect -! Data exchange among processes. -! -! Takes care of Y an encaspulated multivector. -! -! -subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_zswapdata_multivect - use psb_z_base_multivect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_zswap_vidx_vect + + ! + ! + ! Subroutine: psi_zswapdata_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_multivect_type) :: y - complex(psb_dpk_) :: beta - complex(psb_dpk_), target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type) :: y + complex(psb_dpk_) :: beta + complex(psb_dpk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) return -end subroutine psi_zswapdata_multivect +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_zswapdata_multivect + + + ! + ! + ! Subroutine: psi_zswap_vidx_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods + ! of multivectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_zswap_vidx_multivect(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_zswap_vidx_multivect -! Data exchange among processes. -! -! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods -! of multivectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_zswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_zswap_vidx_multivect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_z_base_multivect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_multivect_type) :: y - complex(psb_dpk_) :: beta - complex(psb_dpk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n = y%get_ncols() - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type) :: y + complex(psb_dpk_) :: beta + complex(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + n = y%get_ncols() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_dcomplex_swap_tag + call mpi_irecv(y%combuf(rcv_pt),n*nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call y%gth(idx_pt,snd_pt,nesd,idx) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait for device + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_dcomplex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),n*nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - p2ptag = psb_dcomplex_swap_tag - call mpi_irecv(y%combuf(rcv_pt),n*nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call y%gth(idx_pt,snd_pt,nesd,idx) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait for device - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_dcomplex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - if ((nesd>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(snd_pt),n*nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_dcomplex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm /= me)then - if (nesd>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_dcomplex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nerv>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+n*nerv-1) + call y%sct(idx_pt,rcv_pt,nerv,idx,beta) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(rcv_pt:rcv_pt+n*nerv-1) - call y%sct(idx_pt,rcv_pt,nerv,idx,beta) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for com, cleanup comid - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return -end subroutine psi_zswap_vidx_multivect + return + end subroutine psi_zswap_vidx_multivect +end submodule psi_z_swapdata_impl diff --git a/base/comm/internals/psi_zswapdata_a.F90 b/base/comm/internals/psi_zswapdata_a.F90 index a4db9bb8..471eecd5 100644 --- a/base/comm/internals/psi_zswapdata_a.F90 +++ b/base/comm/internals/psi_zswapdata_a.F90 @@ -84,912 +84,899 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) +submodule (psi_z_comm_a_mod) psi_z_swapdata_a_impl + use psb_base_mod +contains + module subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_zswapdatam - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta - complex(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info +complex(psb_dpk_) :: y(:,:), beta +complex(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_zswapdatam + end subroutine psi_zswapdatam -subroutine psi_zswapidxm(ctxt,icomm,flag,n,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) + module subroutine psi_zswapidxm(ctxt,flag,n,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) - use psi_mod, psb_protect_name => psi_zswapidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta - complex(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - - integer(psb_mpk_) :: np, me, nesd, nerv - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info +complex(psb_dpk_) :: y(:,:), beta +complex(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + + integer(psb_mpk_) :: np, me, nesd, nerv + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_mpk_) :: icomm + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + +complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if - ! prepare info for communications + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + end if - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_c_dpk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_c_dpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_dcomplex_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_c_dpk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_c_dpk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_dcomplex_swap_tag + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_dcomplex_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*)& + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_sync) then - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + else if (swap_send) then - if (proc_to_comm < me) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_snd(ctxt,& & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nerv>0) call psb_rcv(ctxt,& & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - end do + end if + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then + end if - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_dcomplex_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_dcomplex_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),n*nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),n*nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,iret) - end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_dcomplex_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*)& - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_zswapidxm + end subroutine psi_zswapidxm + + ! + ! + ! Subroutine: psi_zswapdatav + ! Implements the data exchange among processes. Essentially this is doing + ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but + ! it is capable of pruning empty exchanges, which are very likely in out + ! application environment. All the variants have the same structure + ! In all these subroutines X may be: I Integer + ! S real(psb_spk_) + ! D real(psb_dpk_) + ! C complex(psb_spk_) + ! Z complex(psb_dpk_) + ! Basically the operation is as follows: on each process, we identify + ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); + ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y + ! but only on the elements involved in the UNPACK operation. + ! Thus: for halo data exchange, the receive section is confined in the + ! halo indices, and BETA=0, whereas for overlap exchange the receive section + ! is scattered in the owned indices, and BETA=1. + ! The first routine picks the desired exchange index list and passes it to the second. + ! + ! Arguments: + ! flag - integer Choose the algorithm for data exchange: + ! this is chosen through bit fields. + ! 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 + ! if (swap_mpi): use underlying MPI_ALLTOALLV. + ! if (swap_sync): use PSB_SND and PSB_RCV in + ! synchronized pairs + ! if (swap_send .and. swap_recv): use mpi_irecv + ! and mpi_send + ! if (swap_send): use psb_snd (but need another + ! call with swap_recv to complete) + ! if (swap_recv): use psb_rcv (completing a + ! previous call with swap_send) + ! + ! + ! n - integer Number of columns in Y + ! beta - complex Choose overwrite or sum. + ! y(:) - complex The data area + ! desc_a - type(psb_desc_type). The communication descriptor. + ! work(:) - complex Buffer space. If not sufficient, will do + ! our own internal allocation. + ! info - integer. return code. + ! data - integer which list is to be used to exchange data + ! default psb_comm_halo_ + ! psb_comm_halo_ use halo_index + ! psb_comm_ext_ use ext_index + ! psb_comm_ovrl_ use ovrl_index + ! psb_comm_mov_ use ovr_mst_idx + ! + ! + module subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) -! -! -! Subroutine: psi_zswapdatav -! Implements the data exchange among processes. Essentially this is doing -! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! The first routine picks the desired exchange index list and passes it to the second. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! 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 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - complex Choose overwrite or sum. -! y(:) - complex The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - complex Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_zswapdatav - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:), beta - complex(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:), beta + complex(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif - return -end subroutine psi_zswapdatav + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if -! -! -! Subroutine: psi_zswapdataidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_zswapidxv(ctxt,icomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) + call psi_swapdata(ctxt,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) - use psi_mod, psb_protect_name => psi_zswapidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_zswapdatav + + + ! + ! + ! Subroutine: psi_zswapdataidxv + ! Does the data exchange among processes. + ! + ! The real workhorse: the outer routines will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_zswapidxv(ctxt,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psb_error_mod + use psb_desc_mod + use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:), beta - complex(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:), beta + complex(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + integer(psb_mpk_) :: icomm + logical, parameter :: usersend=.false. + + complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications + ! prepare info for communications - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - end do + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - end if - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_c_dpk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_c_dpk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. end if - else if (swap_sync) then - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + if (do_send) then - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_c_dpk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_c_dpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_dcomplex_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_dcomplex_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_dcomplex_swap_tag - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_dcomplex_swap_tag + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_dcomplex_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,iret) + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) end if + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_dcomplex_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_zswapidxv + end subroutine psi_zswapidxv +end submodule psi_z_swapdata_a_impl diff --git a/base/comm/internals/psi_zswaptran.F90 b/base/comm/internals/psi_zswaptran.F90 index 2d0c39c4..465337a5 100644 --- a/base/comm/internals/psi_zswaptran.F90 +++ b/base/comm/internals/psi_zswaptran.F90 @@ -91,418 +91,406 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data) +submodule (psi_z_comm_v_mod) psi_z_swaptran_impl + use psb_base_mod +contains + module subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_zswaptran_vect - use psb_z_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_vect_type) :: y - complex(psb_dpk_) :: beta - complex(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_vect_type) :: y + complex(psb_dpk_) :: beta + complex(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_zswaptran_vect + end subroutine psi_zswaptran_vect + + ! + ! + ! Subroutine: psi_ztran_vidx_vect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated vector. Relies on the gather/scatter methods + ! of vectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_ztran_vidx_vect(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) -! -! -! Subroutine: psi_ztran_vidx_vect -! Data exchange among processes. -! -! Takes care of Y an encapsulated vector. Relies on the gather/scatter methods -! of vectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_ztran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_ztran_vidx_vect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_z_base_vect_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_vect_type) :: y - complex(psb_dpk_) :: beta - complex(psb_dpk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - p2ptag = psb_dcomplex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt - call mpi_irecv(y%combuf(snd_pt),nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - idx_pt = rcv_pt - call y%gth(idx_pt,nerv,idx) - - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - p2ptag = psb_dcomplex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if ((nerv>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(rcv_pt),nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_vect_type) :: y + complex(psb_dpk_) :: beta + complex(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + p2ptag = psb_dcomplex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + call mpi_irecv(y%combuf(snd_pt),nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + idx_pt = rcv_pt + call y%gth(idx_pt,nerv,idx) + + pnti = pnti + nerv + nesd + 3 + end do - pnti = pnti + nerv + nesd + 3 - end do - end if + ! + ! Then wait + ! + call y%device_wait() - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... + if (debug) write(*,*) me,' isend' ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_dcomplex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - p2ptag = psb_dcomplex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (proc_to_comm /= me)then - if (nerv>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_dcomplex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+nesd-1) + call y%sct(snd_pt,nesd,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 end if - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - snd_pt = 1+pnti+nerv+psb_n_elem_send_ - rcv_pt = 1+pnti+psb_n_elem_recv_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(snd_pt:snd_pt+nesd-1) - call y%sct(snd_pt,nesd,idx,beta) - pnti = pnti + nerv + nesd + 3 - end do - ! - ! Waited for everybody, clean up - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + if (debug) write(*,*) me,' done' end if - if (debug) write(*,*) me,' done' - end if - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) - return + return -end subroutine psi_ztran_vidx_vect + end subroutine psi_ztran_vidx_vect -! -! -! -! -! Subroutine: psi_zswaptran_multivect -! Data exchange among processes. -! -! Takes care of Y an encaspulated multivector. -! -! -subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data) + ! + ! + ! + ! + ! Subroutine: psi_zswaptran_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encaspulated multivector. + ! + ! + module subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_zswaptran_multivect - use psb_z_base_vect_mod - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_multivect_type) :: y - complex(psb_dpk_) :: beta - complex(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - class(psb_i_base_vect_type), pointer :: d_vidx - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type) :: y + complex(psb_dpk_) :: beta + complex(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) @@ -510,273 +498,266 @@ subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data) end subroutine psi_zswaptran_multivect -! -! -! Subroutine: psi_ztran_vidx_multivect -! Data exchange among processes. -! -! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods -! of multivectors. -! -! The real workhorse: the outer routine will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_ztran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_ztran_vidx_multivect - use psb_error_mod - use psb_realloc_mod - use psb_desc_mod - use psb_penv_mod - use psb_z_base_multivect_mod + ! + ! + ! Subroutine: psi_ztran_vidx_multivect + ! Data exchange among processes. + ! + ! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods + ! of multivectors. + ! + ! The real workhorse: the outer routine will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_ztran_vidx_multivect(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_z_base_multivect_type) :: y - complex(psb_dpk_) :: beta - complex(psb_dpk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable :: prcid(:) - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false., debug=.false. - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n = y%get_ncols() - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - call idx%sync() - - if (debug) write(*,*) me,'Internal buffer' - if (do_send) then - if (allocated(y%comid)) then - if (any(y%comid /= mpi_request_null)) then - ! - ! Unfinished communication? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_z_base_multivect_type) :: y + complex(psb_dpk_) :: beta + complex(psb_dpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_) :: icomm + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + icomm = ctxt%get_mpic() + + n = y%get_ncols() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_dcomplex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt + call mpi_irecv(y%combuf(snd_pt),n*nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call y%gth(idx_pt,rcv_pt,nerv,idx) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait for device + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_dcomplex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),n*nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do end if - if (debug) write(*,*) me,'do_send start' - call y%new_buffer(ione*size(idx%v),info) - call y%new_comid(totxch,info) - y%comid = mpi_request_null - call psb_realloc(totxch,prcid,info) - ! First I post all the non blocking receives - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_dcomplex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt - call mpi_irecv(y%combuf(snd_pt),n*nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag, icomm,y%comid(i,2),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' Gather ' - ! - ! Then gather for sending. - ! - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call y%gth(idx_pt,rcv_pt,nerv,idx) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - ! - ! Then wait for device - ! - call y%device_wait() - - if (debug) write(*,*) me,' isend' - ! - ! Then send - ! - - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_dcomplex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - if ((nerv>0).and.(proc_to_comm /= me)) then - call mpi_isend(y%combuf(rcv_pt),n*nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,y%comid(i,1),iret) - end if - if(iret /= mpi_success) then + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - end if - - if (do_recv) then - if (debug) write(*,*) me,' do_Recv' - if (.not.allocated(y%comid)) then - ! - ! No matching send? Something is wrong.... - ! - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/-2/)) - goto 9999 - end if - call psb_realloc(totxch,prcid,info) - - if (debug) write(*,*) me,' wait' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - p2ptag = psb_dcomplex_swap_tag - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm /= me)then - if (nerv>0) then - call mpi_wait(y%comid(i,1),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_dcomplex_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if - end if - if (nesd>0) then - call mpi_wait(y%comid(i,2),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1) end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - if (debug) write(*,*) me,' scatter' - pnti = 1 - snd_pt = totrcv_+1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx%v(pnti+psb_proc_id_) - nerv = idx%v(pnti+psb_n_elem_recv_) - nesd = idx%v(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - - if (debug) write(0,*)me,' Received from: ',prcid(i),& - & y%combuf(snd_pt:snd_pt+n*nesd-1) - call y%sct(idx_pt,snd_pt,nesd,idx,beta) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! - ! Waited for com, cleanup comid - ! - y%comid = mpi_request_null - - ! - ! Then wait for device - ! - if (debug) write(*,*) me,' wait' - call y%device_wait() - if (debug) write(*,*) me,' free buffer' - call y%maybe_free_buffer(info) - if (info == 0) call y%free_comid(info) - if (info /= 0) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if (debug) write(*,*) me,' done' - end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+n*nesd-1) + call y%sct(idx_pt,snd_pt,nesd,idx,beta) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - call psb_erractionrestore(err_act) - return + ! + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null -9999 call psb_error_handler(ctxt,err_act) + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if - return -end subroutine psi_ztran_vidx_multivect + call psb_erractionrestore(err_act) + return +9999 call psb_error_handler(ctxt,err_act) + return + end subroutine psi_ztran_vidx_multivect +end submodule psi_z_swaptran_impl diff --git a/base/comm/internals/psi_zswaptran_a.F90 b/base/comm/internals/psi_zswaptran_a.F90 index 5e82f3f7..2ea4d2b8 100644 --- a/base/comm/internals/psi_zswaptran_a.F90 +++ b/base/comm/internals/psi_zswaptran_a.F90 @@ -88,922 +88,909 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) +submodule (psi_z_comm_a_mod) psi_z_swaptran_a_impl + use psb_base_mod +contains + module subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) - use psi_mod, psb_protect_name => psi_zswaptranm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta - complex(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_mpk_) :: np, me - integer(psb_ipk_) :: idxs, idxr, err_act, totxch, data_ - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:,:), beta + complex(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_mpk_) :: np, me + integer(psb_ipk_) :: idxs, idxr, err_act, totxch, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ctxt,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) return -end subroutine psi_zswaptranm -subroutine psi_ztranidxm(ctxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) +9999 call psb_error_handler(ctxt,err_act) - use psi_mod, psb_protect_name => psi_ztranidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + return + end subroutine psi_zswaptranm + + module subroutine psi_ztranidxm(ctxt,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_mpk_), intent(in) :: n - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta - complex(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_mpk_), intent(in) :: n + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:,:), beta + complex(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + integer(psb_mpk_) :: icomm + logical, parameter :: usersend=.false. + + complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - 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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if - ! prepare info for communications + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + if (do_send) then - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd + call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 end if - albf=.true. - end if - if (do_send) then - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) + ! Case SWAP_MPI + if (swap_mpi) then - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_c_dpk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_c_dpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if - end if + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_dcomplex_swap_tag + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_dcomplex_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - ! Case SWAP_MPI - if (swap_mpi) then + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_c_dpk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_c_dpk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_dcomplex_swap_tag - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send',& + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do + pnti = pnti + nerv + nesd + 3 + end do - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_dcomplex_swap_tag - call mpi_irecv(sndbuf(snd_pt),n*nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do + else if (swap_send) then + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + else if (swap_recv) then - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_dcomplex_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,iret) - end if + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 + end if - end do + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_dcomplex_swap_tag + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send',& - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_ztranidxm -! -! -! Subroutine: psi_zswaptranv -! Implements the data exchange among processes. This is similar to Xswapdata, but -! the list is read "in reverse", i.e. indices that are normally SENT are used -! for the RECEIVE part and vice-versa. This is the basic data exchange operation -! for doing the product of a sparse matrix by a vector. -! Essentially this is doing a variable all-to-all data exchange -! (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! The first routine picks the desired exchange index list and passes it to the second. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! 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 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - complex Choose overwrite or sum. -! y(:) - complex The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - complex Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_zswaptranv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + end subroutine psi_ztranidxm + ! + ! + ! Subroutine: psi_zswaptranv + ! Implements the data exchange among processes. This is similar to Xswapdata, but + ! the list is read "in reverse", i.e. indices that are normally SENT are used + ! for the RECEIVE part and vice-versa. This is the basic data exchange operation + ! for doing the product of a sparse matrix by a vector. + ! Essentially this is doing a variable all-to-all data exchange + ! (ALLTOALLV in MPI parlance), but + ! it is capable of pruning empty exchanges, which are very likely in out + ! application environment. All the variants have the same structure + ! In all these subroutines X may be: I Integer + ! S real(psb_spk_) + ! D real(psb_dpk_) + ! C complex(psb_spk_) + ! Z complex(psb_dpk_) + ! Basically the operation is as follows: on each process, we identify + ! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); + ! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y + ! but only on the elements involved in the UNPACK operation. + ! Thus: for halo data exchange, the receive section is confined in the + ! halo indices, and BETA=0, whereas for overlap exchange the receive section + ! is scattered in the owned indices, and BETA=1. + ! The first routine picks the desired exchange index list and passes it to the second. + ! + ! Arguments: + ! flag - integer Choose the algorithm for data exchange: + ! this is chosen through bit fields. + ! 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 + ! if (swap_mpi): use underlying MPI_ALLTOALLV. + ! if (swap_sync): use PSB_SND and PSB_RCV in + ! synchronized pairs + ! if (swap_send .and. swap_recv): use mpi_irecv + ! and mpi_send + ! if (swap_send): use psb_snd (but need another + ! call with swap_recv to complete) + ! if (swap_recv): use psb_rcv (completing a + ! previous call with swap_send) + ! + ! + ! n - integer Number of columns in Y + ! beta - complex Choose overwrite or sum. + ! y(:) - complex The data area + ! desc_a - type(psb_desc_type). The communication descriptor. + ! work(:) - complex Buffer space. If not sufficient, will do + ! our own internal allocation. + ! info - integer. return code. + ! data - integer which list is to be used to exchange data + ! default psb_comm_halo_ + ! psb_comm_halo_ use halo_index + ! psb_comm_ext_ use ext_index + ! psb_comm_ovrl_ use ovrl_index + ! psb_comm_mov_ use ovr_mst_idx + ! + ! + module subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:), beta - complex(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - type(psb_ctxt_type) :: ctxt - integer(psb_mpk_) :: icomm - integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ctxt = desc_a%get_context() - icomm = ctxt%get_mpic() - call psb_info(ctxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ctxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:), beta + complex(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_mpk_) :: icomm + integer(psb_ipk_) :: np, me, idxs, idxr, totxch, err_act, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ctxt = desc_a%get_context() + icomm = ctxt%get_mpic() + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif -9999 call psb_error_handler(ctxt,err_act) + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif - return -end subroutine psi_zswaptranv + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + call desc_a%get_list_p(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if -! -! -! Subroutine: psi_ztranidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_ztranidxv(ctxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) + call psi_swaptran(ctxt,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 - use psi_mod, psb_protect_name => psi_ztranidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + end subroutine psi_zswaptranv + + + ! + ! + ! Subroutine: psi_ztranidxv + ! Does the data exchange among processes. + ! + ! The real workhorse: the outer routines will only choose the index list + ! this one takes the index list and does the actual exchange. + ! + ! + ! + module subroutine psi_ztranidxv(ctxt,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) #ifdef PSB_MPI_MOD - use mpi + use mpi #endif - implicit none + implicit none #ifdef PSB_MPI_H - include 'mpif.h' + include 'mpif.h' #endif - type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:), beta - complex(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpk_) :: np, me, nesd, nerv, n - integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf + type(psb_ctxt_type), intent(in) :: ctxt + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:), beta + complex(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: np, me, nesd, nerv, n + integer(psb_mpk_) :: proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + integer(psb_mpk_) :: icomm + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf #if !defined(PSB_CMP_FLANG) - volatile :: sndbuf, rcvbuf + volatile :: sndbuf, rcvbuf #endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - call psb_info(ctxt,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 - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + call psb_info(ctxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) goto 9999 - end if + endif + icomm = ctxt%get_mpic() + + 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 + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 - ! prepare info for communications + ! prepare info for communications - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(proc_to_comm) = psb_get_mpi_rank(ctxt,proc_to_comm) - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 - end do + end do - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if end if - end if - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_c_dpk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_c_dpk_,icomm,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - else if (swap_sync) then + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_c_dpk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_c_dpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ctxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ctxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_dcomplex_swap_tag + call mpi_irecv(sndbuf(snd_pt),nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_dcomplex_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (proc_to_comm < me) then + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_dcomplex_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nerv>0) call psb_snd(ctxt,& & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) if (nesd>0) call psb_rcv(ctxt,& & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - prcid(i) = psb_get_mpi_rank(ctxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_dcomplex_swap_tag - call mpi_irecv(sndbuf(snd_pt),nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + end if - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) + end if - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_dcomplex_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag, icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag, icomm,iret) - end if + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_dcomplex_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,m_err=(/iret/)) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ctxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ctxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 call psb_error_handler(ctxt,err_act) return -end subroutine psi_ztranidxv + end subroutine psi_ztranidxv +end submodule psi_z_swaptran_a_impl diff --git a/base/modules/comm/psi_c_comm_a_mod.f90 b/base/modules/comm/psi_c_comm_a_mod.f90 index ce2da78d..97b5f958 100644 --- a/base/modules/comm/psi_c_comm_a_mod.f90 +++ b/base/modules/comm/psi_c_comm_a_mod.f90 @@ -34,8 +34,7 @@ module psi_c_comm_a_mod use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_spk_, psb_i_base_vect_type interface psi_swapdata - subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) - import + module subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -44,8 +43,7 @@ module psi_c_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_cswapdatam - subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: y(:), beta @@ -53,11 +51,9 @@ module psi_c_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_cswapdatav - subroutine psi_cswapidxm(ctxt,icomm,flag,n,beta,y,idx,& + module subroutine psi_cswapidxm(ctxt,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -65,11 +61,9 @@ module psi_c_comm_a_mod complex(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_cswapidxm - subroutine psi_cswapidxv(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_cswapidxv(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_Mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: y(:), beta @@ -80,8 +74,7 @@ module psi_c_comm_a_mod interface psi_swaptran - subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) - import + module subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_Mpk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -90,8 +83,7 @@ module psi_c_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_cswaptranm - subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: y(:), beta @@ -99,11 +91,9 @@ module psi_c_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_cswaptranv - subroutine psi_ctranidxm(ctxt,icomm,flag,n,beta,y,idx,& + module subroutine psi_ctranidxm(ctxt,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -111,11 +101,9 @@ module psi_c_comm_a_mod complex(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_ctranidxm - subroutine psi_ctranidxv(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_ctranidxv(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: y(:), beta @@ -123,17 +111,15 @@ module psi_c_comm_a_mod integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_ctranidxv end interface psi_swaptran - + interface psi_ovrl_upd - subroutine psi_covrl_updr1(x,desc_a,update,info) - import + module subroutine psi_covrl_updr1(x,desc_a,update,info) complex(psb_spk_), intent(inout), target :: x(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_updr1 - subroutine psi_covrl_updr2(x,desc_a,update,info) - import + module subroutine psi_covrl_updr2(x,desc_a,update,info) complex(psb_spk_), intent(inout), target :: x(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update @@ -142,15 +128,13 @@ module psi_c_comm_a_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_covrl_saver1(x,xs,desc_a,info) - import + module subroutine psi_covrl_saver1(x,xs,desc_a,info) complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_saver1 - subroutine psi_covrl_saver2(x,xs,desc_a,info) - import + module subroutine psi_covrl_saver2(x,xs,desc_a,info) complex(psb_spk_), intent(inout) :: x(:,:) complex(psb_spk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -159,15 +143,13 @@ module psi_c_comm_a_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_covrl_restrr1(x,xs,desc_a,info) - import + module subroutine psi_covrl_restrr1(x,xs,desc_a,info) complex(psb_spk_), intent(inout) :: x(:) complex(psb_spk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_restrr1 - subroutine psi_covrl_restrr2(x,xs,desc_a,info) - import + module subroutine psi_covrl_restrr2(x,xs,desc_a,info) complex(psb_spk_), intent(inout) :: x(:,:) complex(psb_spk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a diff --git a/base/modules/comm/psi_c_comm_v_mod.f90 b/base/modules/comm/psi_c_comm_v_mod.f90 index 7d10a028..9f7c8758 100644 --- a/base/modules/comm/psi_c_comm_v_mod.f90 +++ b/base/modules/comm/psi_c_comm_v_mod.f90 @@ -36,8 +36,7 @@ module psi_c_comm_v_mod use psb_c_base_multivect_mod, only : psb_c_base_multivect_type interface psi_swapdata - subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_c_base_vect_type) :: y @@ -46,8 +45,7 @@ module psi_c_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_cswapdata_vect - subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_cswapdata_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_c_base_multivect_type) :: y @@ -56,11 +54,9 @@ module psi_c_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_cswapdata_multivect - subroutine psi_cswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_cswap_vidx_vect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_c_base_vect_type) :: y @@ -69,11 +65,9 @@ module psi_c_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_cswap_vidx_vect - subroutine psi_cswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_cswap_vidx_multivect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_c_base_multivect_type) :: y @@ -86,8 +80,7 @@ module psi_c_comm_v_mod interface psi_swaptran - subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_c_base_vect_type) :: y @@ -96,8 +89,7 @@ module psi_c_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_cswaptran_vect - subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_c_base_multivect_type) :: y @@ -106,11 +98,9 @@ module psi_c_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_cswaptran_multivect - subroutine psi_ctran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_ctran_vidx_vect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_c_base_vect_type) :: y @@ -119,11 +109,9 @@ module psi_c_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_ctran_vidx_vect - subroutine psi_ctran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_ctran_vidx_multivect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_c_base_multivect_type) :: y @@ -135,15 +123,13 @@ module psi_c_comm_v_mod end interface psi_swaptran interface psi_ovrl_upd - subroutine psi_covrl_upd_vect(x,desc_a,update,info) - import + module subroutine psi_covrl_upd_vect(x,desc_a,update,info) class(psb_c_base_vect_type) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_upd_vect - subroutine psi_covrl_upd_multivect(x,desc_a,update,info) - import + module subroutine psi_covrl_upd_multivect(x,desc_a,update,info) class(psb_c_base_multivect_type) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update @@ -152,15 +138,13 @@ module psi_c_comm_v_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_covrl_save_vect(x,xs,desc_a,info) - import + module subroutine psi_covrl_save_vect(x,xs,desc_a,info) class(psb_c_base_vect_type) :: x complex(psb_spk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_save_vect - subroutine psi_covrl_save_multivect(x,xs,desc_a,info) - import + module subroutine psi_covrl_save_multivect(x,xs,desc_a,info) class(psb_c_base_multivect_type) :: x complex(psb_spk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -169,15 +153,13 @@ module psi_c_comm_v_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_covrl_restr_vect(x,xs,desc_a,info) - import + module subroutine psi_covrl_restr_vect(x,xs,desc_a,info) class(psb_c_base_vect_type) :: x complex(psb_spk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_covrl_restr_vect - subroutine psi_covrl_restr_multivect(x,xs,desc_a,info) - import + module subroutine psi_covrl_restr_multivect(x,xs,desc_a,info) class(psb_c_base_multivect_type) :: x complex(psb_spk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a diff --git a/base/modules/comm/psi_d_comm_a_mod.f90 b/base/modules/comm/psi_d_comm_a_mod.f90 index b1dda3f8..46f02142 100644 --- a/base/modules/comm/psi_d_comm_a_mod.f90 +++ b/base/modules/comm/psi_d_comm_a_mod.f90 @@ -34,8 +34,7 @@ module psi_d_comm_a_mod use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_dpk_, psb_i_base_vect_type interface psi_swapdata - subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) - import + module subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -44,8 +43,7 @@ module psi_d_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswapdatam - subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: y(:), beta @@ -53,11 +51,9 @@ module psi_d_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswapdatav - subroutine psi_dswapidxm(ctxt,icomm,flag,n,beta,y,idx,& + module subroutine psi_dswapidxm(ctxt,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -65,11 +61,9 @@ module psi_d_comm_a_mod real(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_dswapidxm - subroutine psi_dswapidxv(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_dswapidxv(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_Mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: y(:), beta @@ -80,8 +74,7 @@ module psi_d_comm_a_mod interface psi_swaptran - subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) - import + module subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_Mpk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -90,8 +83,7 @@ module psi_d_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswaptranm - subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: y(:), beta @@ -99,11 +91,9 @@ module psi_d_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswaptranv - subroutine psi_dtranidxm(ctxt,icomm,flag,n,beta,y,idx,& + module subroutine psi_dtranidxm(ctxt,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -111,11 +101,9 @@ module psi_d_comm_a_mod real(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_dtranidxm - subroutine psi_dtranidxv(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_dtranidxv(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: y(:), beta @@ -123,17 +111,15 @@ module psi_d_comm_a_mod integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_dtranidxv end interface psi_swaptran - + interface psi_ovrl_upd - subroutine psi_dovrl_updr1(x,desc_a,update,info) - import + module subroutine psi_dovrl_updr1(x,desc_a,update,info) real(psb_dpk_), intent(inout), target :: x(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_updr1 - subroutine psi_dovrl_updr2(x,desc_a,update,info) - import + module subroutine psi_dovrl_updr2(x,desc_a,update,info) real(psb_dpk_), intent(inout), target :: x(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update @@ -142,15 +128,13 @@ module psi_d_comm_a_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_dovrl_saver1(x,xs,desc_a,info) - import + module subroutine psi_dovrl_saver1(x,xs,desc_a,info) real(psb_dpk_), intent(inout) :: x(:) real(psb_dpk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_saver1 - subroutine psi_dovrl_saver2(x,xs,desc_a,info) - import + module subroutine psi_dovrl_saver2(x,xs,desc_a,info) real(psb_dpk_), intent(inout) :: x(:,:) real(psb_dpk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -159,15 +143,13 @@ module psi_d_comm_a_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_dovrl_restrr1(x,xs,desc_a,info) - import + module subroutine psi_dovrl_restrr1(x,xs,desc_a,info) real(psb_dpk_), intent(inout) :: x(:) real(psb_dpk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_restrr1 - subroutine psi_dovrl_restrr2(x,xs,desc_a,info) - import + module subroutine psi_dovrl_restrr2(x,xs,desc_a,info) real(psb_dpk_), intent(inout) :: x(:,:) real(psb_dpk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a diff --git a/base/modules/comm/psi_d_comm_v_mod.f90 b/base/modules/comm/psi_d_comm_v_mod.f90 index b7a902da..5893d76b 100644 --- a/base/modules/comm/psi_d_comm_v_mod.f90 +++ b/base/modules/comm/psi_d_comm_v_mod.f90 @@ -36,8 +36,7 @@ module psi_d_comm_v_mod use psb_d_base_multivect_mod, only : psb_d_base_multivect_type interface psi_swapdata - subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_d_base_vect_type) :: y @@ -46,8 +45,7 @@ module psi_d_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswapdata_vect - subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_dswapdata_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_d_base_multivect_type) :: y @@ -56,11 +54,9 @@ module psi_d_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswapdata_multivect - subroutine psi_dswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_dswap_vidx_vect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_d_base_vect_type) :: y @@ -69,11 +65,9 @@ module psi_d_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_dswap_vidx_vect - subroutine psi_dswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_dswap_vidx_multivect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_d_base_multivect_type) :: y @@ -86,8 +80,7 @@ module psi_d_comm_v_mod interface psi_swaptran - subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_d_base_vect_type) :: y @@ -96,8 +89,7 @@ module psi_d_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswaptran_vect - subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_d_base_multivect_type) :: y @@ -106,11 +98,9 @@ module psi_d_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswaptran_multivect - subroutine psi_dtran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_dtran_vidx_vect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_d_base_vect_type) :: y @@ -119,11 +109,9 @@ module psi_d_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_dtran_vidx_vect - subroutine psi_dtran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_dtran_vidx_multivect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_d_base_multivect_type) :: y @@ -135,15 +123,13 @@ module psi_d_comm_v_mod end interface psi_swaptran interface psi_ovrl_upd - subroutine psi_dovrl_upd_vect(x,desc_a,update,info) - import + module subroutine psi_dovrl_upd_vect(x,desc_a,update,info) class(psb_d_base_vect_type) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_upd_vect - subroutine psi_dovrl_upd_multivect(x,desc_a,update,info) - import + module subroutine psi_dovrl_upd_multivect(x,desc_a,update,info) class(psb_d_base_multivect_type) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update @@ -152,15 +138,13 @@ module psi_d_comm_v_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_dovrl_save_vect(x,xs,desc_a,info) - import + module subroutine psi_dovrl_save_vect(x,xs,desc_a,info) class(psb_d_base_vect_type) :: x real(psb_dpk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_save_vect - subroutine psi_dovrl_save_multivect(x,xs,desc_a,info) - import + module subroutine psi_dovrl_save_multivect(x,xs,desc_a,info) class(psb_d_base_multivect_type) :: x real(psb_dpk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -169,15 +153,13 @@ module psi_d_comm_v_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_dovrl_restr_vect(x,xs,desc_a,info) - import + module subroutine psi_dovrl_restr_vect(x,xs,desc_a,info) class(psb_d_base_vect_type) :: x real(psb_dpk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_dovrl_restr_vect - subroutine psi_dovrl_restr_multivect(x,xs,desc_a,info) - import + module subroutine psi_dovrl_restr_multivect(x,xs,desc_a,info) class(psb_d_base_multivect_type) :: x real(psb_dpk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a diff --git a/base/modules/comm/psi_e_comm_a_mod.f90 b/base/modules/comm/psi_e_comm_a_mod.f90 index 4b6c5104..9e215e7c 100644 --- a/base/modules/comm/psi_e_comm_a_mod.f90 +++ b/base/modules/comm/psi_e_comm_a_mod.f90 @@ -34,8 +34,7 @@ module psi_e_comm_a_mod use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_epk_ interface psi_swapdata - subroutine psi_eswapdatam(flag,n,beta,y,desc_a,work,info,data) - import + module subroutine psi_eswapdatam(flag,n,beta,y,desc_a,work,info,data) integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -44,8 +43,7 @@ module psi_e_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_eswapdatam - subroutine psi_eswapdatav(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_eswapdatav(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info integer(psb_epk_) :: y(:), beta @@ -53,11 +51,9 @@ module psi_e_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_eswapdatav - subroutine psi_eswapidxm(ctxt,icomm,flag,n,beta,y,idx,& + module subroutine psi_eswapidxm(ctxt,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -65,11 +61,9 @@ module psi_e_comm_a_mod integer(psb_epk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_eswapidxm - subroutine psi_eswapidxv(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_eswapidxv(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_Mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info integer(psb_epk_) :: y(:), beta @@ -80,8 +74,7 @@ module psi_e_comm_a_mod interface psi_swaptran - subroutine psi_eswaptranm(flag,n,beta,y,desc_a,work,info,data) - import + module subroutine psi_eswaptranm(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_Mpk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -90,8 +83,7 @@ module psi_e_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_eswaptranm - subroutine psi_eswaptranv(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_eswaptranv(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info integer(psb_epk_) :: y(:), beta @@ -99,11 +91,9 @@ module psi_e_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_eswaptranv - subroutine psi_etranidxm(ctxt,icomm,flag,n,beta,y,idx,& + module subroutine psi_etranidxm(ctxt,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -111,11 +101,9 @@ module psi_e_comm_a_mod integer(psb_epk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_etranidxm - subroutine psi_etranidxv(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_etranidxv(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info integer(psb_epk_) :: y(:), beta @@ -123,17 +111,15 @@ module psi_e_comm_a_mod integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_etranidxv end interface psi_swaptran - + interface psi_ovrl_upd - subroutine psi_eovrl_updr1(x,desc_a,update,info) - import + module subroutine psi_eovrl_updr1(x,desc_a,update,info) integer(psb_epk_), intent(inout), target :: x(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_eovrl_updr1 - subroutine psi_eovrl_updr2(x,desc_a,update,info) - import + module subroutine psi_eovrl_updr2(x,desc_a,update,info) integer(psb_epk_), intent(inout), target :: x(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update @@ -142,15 +128,13 @@ module psi_e_comm_a_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_eovrl_saver1(x,xs,desc_a,info) - import + module subroutine psi_eovrl_saver1(x,xs,desc_a,info) integer(psb_epk_), intent(inout) :: x(:) integer(psb_epk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_eovrl_saver1 - subroutine psi_eovrl_saver2(x,xs,desc_a,info) - import + module subroutine psi_eovrl_saver2(x,xs,desc_a,info) integer(psb_epk_), intent(inout) :: x(:,:) integer(psb_epk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -159,15 +143,13 @@ module psi_e_comm_a_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_eovrl_restrr1(x,xs,desc_a,info) - import + module subroutine psi_eovrl_restrr1(x,xs,desc_a,info) integer(psb_epk_), intent(inout) :: x(:) integer(psb_epk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_eovrl_restrr1 - subroutine psi_eovrl_restrr2(x,xs,desc_a,info) - import + module subroutine psi_eovrl_restrr2(x,xs,desc_a,info) integer(psb_epk_), intent(inout) :: x(:,:) integer(psb_epk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a diff --git a/base/modules/comm/psi_i2_comm_a_mod.f90 b/base/modules/comm/psi_i2_comm_a_mod.f90 index 484c9824..d6c282f9 100644 --- a/base/modules/comm/psi_i2_comm_a_mod.f90 +++ b/base/modules/comm/psi_i2_comm_a_mod.f90 @@ -34,8 +34,7 @@ module psi_i2_comm_a_mod use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_epk_ interface psi_swapdata - subroutine psi_i2swapdatam(flag,n,beta,y,desc_a,work,info,data) - import + module subroutine psi_i2swapdatam(flag,n,beta,y,desc_a,work,info,data) integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -44,8 +43,7 @@ module psi_i2_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_i2swapdatam - subroutine psi_i2swapdatav(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_i2swapdatav(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info integer(psb_i2pk_) :: y(:), beta @@ -53,11 +51,9 @@ module psi_i2_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_i2swapdatav - subroutine psi_i2swapidxm(ctxt,icomm,flag,n,beta,y,idx,& + module subroutine psi_i2swapidxm(ctxt,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -65,11 +61,9 @@ module psi_i2_comm_a_mod integer(psb_i2pk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_i2swapidxm - subroutine psi_i2swapidxv(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_i2swapidxv(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_Mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info integer(psb_i2pk_) :: y(:), beta @@ -80,8 +74,7 @@ module psi_i2_comm_a_mod interface psi_swaptran - subroutine psi_i2swaptranm(flag,n,beta,y,desc_a,work,info,data) - import + module subroutine psi_i2swaptranm(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_Mpk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -90,8 +83,7 @@ module psi_i2_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_i2swaptranm - subroutine psi_i2swaptranv(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_i2swaptranv(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info integer(psb_i2pk_) :: y(:), beta @@ -99,11 +91,9 @@ module psi_i2_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_i2swaptranv - subroutine psi_i2tranidxm(ctxt,icomm,flag,n,beta,y,idx,& + module subroutine psi_i2tranidxm(ctxt,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -111,11 +101,9 @@ module psi_i2_comm_a_mod integer(psb_i2pk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_i2tranidxm - subroutine psi_i2tranidxv(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_i2tranidxv(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info integer(psb_i2pk_) :: y(:), beta @@ -123,17 +111,15 @@ module psi_i2_comm_a_mod integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_i2tranidxv end interface psi_swaptran - + interface psi_ovrl_upd - subroutine psi_i2ovrl_updr1(x,desc_a,update,info) - import + module subroutine psi_i2ovrl_updr1(x,desc_a,update,info) integer(psb_i2pk_), intent(inout), target :: x(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_i2ovrl_updr1 - subroutine psi_i2ovrl_updr2(x,desc_a,update,info) - import + module subroutine psi_i2ovrl_updr2(x,desc_a,update,info) integer(psb_i2pk_), intent(inout), target :: x(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update @@ -142,15 +128,13 @@ module psi_i2_comm_a_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_i2ovrl_saver1(x,xs,desc_a,info) - import + module subroutine psi_i2ovrl_saver1(x,xs,desc_a,info) integer(psb_i2pk_), intent(inout) :: x(:) integer(psb_i2pk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_i2ovrl_saver1 - subroutine psi_i2ovrl_saver2(x,xs,desc_a,info) - import + module subroutine psi_i2ovrl_saver2(x,xs,desc_a,info) integer(psb_i2pk_), intent(inout) :: x(:,:) integer(psb_i2pk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -159,15 +143,13 @@ module psi_i2_comm_a_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info) - import + module subroutine psi_i2ovrl_restrr1(x,xs,desc_a,info) integer(psb_i2pk_), intent(inout) :: x(:) integer(psb_i2pk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_i2ovrl_restrr1 - subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info) - import + module subroutine psi_i2ovrl_restrr2(x,xs,desc_a,info) integer(psb_i2pk_), intent(inout) :: x(:,:) integer(psb_i2pk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a diff --git a/base/modules/comm/psi_i_comm_v_mod.f90 b/base/modules/comm/psi_i_comm_v_mod.f90 index 2fe3948c..2bc8a0e9 100644 --- a/base/modules/comm/psi_i_comm_v_mod.f90 +++ b/base/modules/comm/psi_i_comm_v_mod.f90 @@ -37,8 +37,7 @@ module psi_i_comm_v_mod use psb_i_base_multivect_mod, only : psb_i_base_multivect_type interface psi_swapdata - subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_i_base_vect_type) :: y @@ -47,8 +46,7 @@ module psi_i_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_iswapdata_vect - subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_i_base_multivect_type) :: y @@ -57,11 +55,9 @@ module psi_i_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_iswapdata_multivect - subroutine psi_iswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_iswap_vidx_vect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_i_base_vect_type) :: y @@ -70,11 +66,9 @@ module psi_i_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_iswap_vidx_vect - subroutine psi_iswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_iswap_vidx_multivect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_i_base_multivect_type) :: y @@ -87,8 +81,7 @@ module psi_i_comm_v_mod interface psi_swaptran - subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_i_base_vect_type) :: y @@ -97,8 +90,7 @@ module psi_i_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_iswaptran_vect - subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_i_base_multivect_type) :: y @@ -107,11 +99,9 @@ module psi_i_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_iswaptran_multivect - subroutine psi_itran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_itran_vidx_vect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_i_base_vect_type) :: y @@ -120,11 +110,9 @@ module psi_i_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_itran_vidx_vect - subroutine psi_itran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_itran_vidx_multivect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_i_base_multivect_type) :: y @@ -136,15 +124,13 @@ module psi_i_comm_v_mod end interface psi_swaptran interface psi_ovrl_upd - subroutine psi_iovrl_upd_vect(x,desc_a,update,info) - import + module subroutine psi_iovrl_upd_vect(x,desc_a,update,info) class(psb_i_base_vect_type) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_iovrl_upd_vect - subroutine psi_iovrl_upd_multivect(x,desc_a,update,info) - import + module subroutine psi_iovrl_upd_multivect(x,desc_a,update,info) class(psb_i_base_multivect_type) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update @@ -153,15 +139,13 @@ module psi_i_comm_v_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_iovrl_save_vect(x,xs,desc_a,info) - import + module subroutine psi_iovrl_save_vect(x,xs,desc_a,info) class(psb_i_base_vect_type) :: x integer(psb_ipk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_iovrl_save_vect - subroutine psi_iovrl_save_multivect(x,xs,desc_a,info) - import + module subroutine psi_iovrl_save_multivect(x,xs,desc_a,info) class(psb_i_base_multivect_type) :: x integer(psb_ipk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -170,15 +154,13 @@ module psi_i_comm_v_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_iovrl_restr_vect(x,xs,desc_a,info) - import + module subroutine psi_iovrl_restr_vect(x,xs,desc_a,info) class(psb_i_base_vect_type) :: x integer(psb_ipk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_iovrl_restr_vect - subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info) - import + module subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info) class(psb_i_base_multivect_type) :: x integer(psb_ipk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a diff --git a/base/modules/comm/psi_l_comm_v_mod.f90 b/base/modules/comm/psi_l_comm_v_mod.f90 index b61a17b7..92768d86 100644 --- a/base/modules/comm/psi_l_comm_v_mod.f90 +++ b/base/modules/comm/psi_l_comm_v_mod.f90 @@ -38,8 +38,7 @@ module psi_l_comm_v_mod use psb_l_base_multivect_mod, only : psb_l_base_multivect_type interface psi_swapdata - subroutine psi_lswapdata_vect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_lswapdata_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_l_base_vect_type) :: y @@ -48,8 +47,7 @@ module psi_l_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_lswapdata_vect - subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_l_base_multivect_type) :: y @@ -58,11 +56,9 @@ module psi_l_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_lswapdata_multivect - subroutine psi_lswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_lswap_vidx_vect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_l_base_vect_type) :: y @@ -71,11 +67,9 @@ module psi_l_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_lswap_vidx_vect - subroutine psi_lswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_lswap_vidx_multivect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_l_base_multivect_type) :: y @@ -88,8 +82,7 @@ module psi_l_comm_v_mod interface psi_swaptran - subroutine psi_lswaptran_vect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_lswaptran_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_l_base_vect_type) :: y @@ -98,8 +91,7 @@ module psi_l_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_lswaptran_vect - subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_l_base_multivect_type) :: y @@ -108,11 +100,9 @@ module psi_l_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_lswaptran_multivect - subroutine psi_ltran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_ltran_vidx_vect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_l_base_vect_type) :: y @@ -121,11 +111,9 @@ module psi_l_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_ltran_vidx_vect - subroutine psi_ltran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_ltran_vidx_multivect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_l_base_multivect_type) :: y @@ -137,15 +125,13 @@ module psi_l_comm_v_mod end interface psi_swaptran interface psi_ovrl_upd - subroutine psi_lovrl_upd_vect(x,desc_a,update,info) - import + module subroutine psi_lovrl_upd_vect(x,desc_a,update,info) class(psb_l_base_vect_type) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_lovrl_upd_vect - subroutine psi_lovrl_upd_multivect(x,desc_a,update,info) - import + module subroutine psi_lovrl_upd_multivect(x,desc_a,update,info) class(psb_l_base_multivect_type) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update @@ -154,15 +140,13 @@ module psi_l_comm_v_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_lovrl_save_vect(x,xs,desc_a,info) - import + module subroutine psi_lovrl_save_vect(x,xs,desc_a,info) class(psb_l_base_vect_type) :: x integer(psb_lpk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_lovrl_save_vect - subroutine psi_lovrl_save_multivect(x,xs,desc_a,info) - import + module subroutine psi_lovrl_save_multivect(x,xs,desc_a,info) class(psb_l_base_multivect_type) :: x integer(psb_lpk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -171,15 +155,13 @@ module psi_l_comm_v_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_lovrl_restr_vect(x,xs,desc_a,info) - import + module subroutine psi_lovrl_restr_vect(x,xs,desc_a,info) class(psb_l_base_vect_type) :: x integer(psb_lpk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_lovrl_restr_vect - subroutine psi_lovrl_restr_multivect(x,xs,desc_a,info) - import + module subroutine psi_lovrl_restr_multivect(x,xs,desc_a,info) class(psb_l_base_multivect_type) :: x integer(psb_lpk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a diff --git a/base/modules/comm/psi_m_comm_a_mod.f90 b/base/modules/comm/psi_m_comm_a_mod.f90 index 825e1579..ac134e65 100644 --- a/base/modules/comm/psi_m_comm_a_mod.f90 +++ b/base/modules/comm/psi_m_comm_a_mod.f90 @@ -34,8 +34,7 @@ module psi_m_comm_a_mod use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_epk_ interface psi_swapdata - subroutine psi_mswapdatam(flag,n,beta,y,desc_a,work,info,data) - import + module subroutine psi_mswapdatam(flag,n,beta,y,desc_a,work,info,data) integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -44,8 +43,7 @@ module psi_m_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_mswapdatam - subroutine psi_mswapdatav(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_mswapdatav(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info integer(psb_mpk_) :: y(:), beta @@ -53,11 +51,9 @@ module psi_m_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_mswapdatav - subroutine psi_mswapidxm(ctxt,icomm,flag,n,beta,y,idx,& + module subroutine psi_mswapidxm(ctxt,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -65,11 +61,9 @@ module psi_m_comm_a_mod integer(psb_mpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_mswapidxm - subroutine psi_mswapidxv(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_mswapidxv(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_Mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info integer(psb_mpk_) :: y(:), beta @@ -80,8 +74,7 @@ module psi_m_comm_a_mod interface psi_swaptran - subroutine psi_mswaptranm(flag,n,beta,y,desc_a,work,info,data) - import + module subroutine psi_mswaptranm(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_Mpk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -90,8 +83,7 @@ module psi_m_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_mswaptranm - subroutine psi_mswaptranv(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_mswaptranv(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info integer(psb_mpk_) :: y(:), beta @@ -99,11 +91,9 @@ module psi_m_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_mswaptranv - subroutine psi_mtranidxm(ctxt,icomm,flag,n,beta,y,idx,& + module subroutine psi_mtranidxm(ctxt,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -111,11 +101,9 @@ module psi_m_comm_a_mod integer(psb_mpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_mtranidxm - subroutine psi_mtranidxv(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_mtranidxv(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info integer(psb_mpk_) :: y(:), beta @@ -123,17 +111,15 @@ module psi_m_comm_a_mod integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_mtranidxv end interface psi_swaptran - + interface psi_ovrl_upd - subroutine psi_movrl_updr1(x,desc_a,update,info) - import + module subroutine psi_movrl_updr1(x,desc_a,update,info) integer(psb_mpk_), intent(inout), target :: x(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_movrl_updr1 - subroutine psi_movrl_updr2(x,desc_a,update,info) - import + module subroutine psi_movrl_updr2(x,desc_a,update,info) integer(psb_mpk_), intent(inout), target :: x(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update @@ -142,15 +128,13 @@ module psi_m_comm_a_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_movrl_saver1(x,xs,desc_a,info) - import + module subroutine psi_movrl_saver1(x,xs,desc_a,info) integer(psb_mpk_), intent(inout) :: x(:) integer(psb_mpk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_movrl_saver1 - subroutine psi_movrl_saver2(x,xs,desc_a,info) - import + module subroutine psi_movrl_saver2(x,xs,desc_a,info) integer(psb_mpk_), intent(inout) :: x(:,:) integer(psb_mpk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -159,15 +143,13 @@ module psi_m_comm_a_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_movrl_restrr1(x,xs,desc_a,info) - import + module subroutine psi_movrl_restrr1(x,xs,desc_a,info) integer(psb_mpk_), intent(inout) :: x(:) integer(psb_mpk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_movrl_restrr1 - subroutine psi_movrl_restrr2(x,xs,desc_a,info) - import + module subroutine psi_movrl_restrr2(x,xs,desc_a,info) integer(psb_mpk_), intent(inout) :: x(:,:) integer(psb_mpk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a diff --git a/base/modules/comm/psi_s_comm_a_mod.f90 b/base/modules/comm/psi_s_comm_a_mod.f90 index 10369b51..3615bb6c 100644 --- a/base/modules/comm/psi_s_comm_a_mod.f90 +++ b/base/modules/comm/psi_s_comm_a_mod.f90 @@ -34,8 +34,7 @@ module psi_s_comm_a_mod use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_spk_, psb_i_base_vect_type interface psi_swapdata - subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) - import + module subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -44,8 +43,7 @@ module psi_s_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_sswapdatam - subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: y(:), beta @@ -53,11 +51,9 @@ module psi_s_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_sswapdatav - subroutine psi_sswapidxm(ctxt,icomm,flag,n,beta,y,idx,& + module subroutine psi_sswapidxm(ctxt,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -65,11 +61,9 @@ module psi_s_comm_a_mod real(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_sswapidxm - subroutine psi_sswapidxv(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_sswapidxv(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_Mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: y(:), beta @@ -80,8 +74,7 @@ module psi_s_comm_a_mod interface psi_swaptran - subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) - import + module subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_Mpk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -90,8 +83,7 @@ module psi_s_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_sswaptranm - subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: y(:), beta @@ -99,11 +91,9 @@ module psi_s_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_sswaptranv - subroutine psi_stranidxm(ctxt,icomm,flag,n,beta,y,idx,& + module subroutine psi_stranidxm(ctxt,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -111,11 +101,9 @@ module psi_s_comm_a_mod real(psb_spk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_stranidxm - subroutine psi_stranidxv(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_stranidxv(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: y(:), beta @@ -123,17 +111,15 @@ module psi_s_comm_a_mod integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_stranidxv end interface psi_swaptran - + interface psi_ovrl_upd - subroutine psi_sovrl_updr1(x,desc_a,update,info) - import + module subroutine psi_sovrl_updr1(x,desc_a,update,info) real(psb_spk_), intent(inout), target :: x(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_updr1 - subroutine psi_sovrl_updr2(x,desc_a,update,info) - import + module subroutine psi_sovrl_updr2(x,desc_a,update,info) real(psb_spk_), intent(inout), target :: x(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update @@ -142,15 +128,13 @@ module psi_s_comm_a_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_sovrl_saver1(x,xs,desc_a,info) - import + module subroutine psi_sovrl_saver1(x,xs,desc_a,info) real(psb_spk_), intent(inout) :: x(:) real(psb_spk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_saver1 - subroutine psi_sovrl_saver2(x,xs,desc_a,info) - import + module subroutine psi_sovrl_saver2(x,xs,desc_a,info) real(psb_spk_), intent(inout) :: x(:,:) real(psb_spk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -159,15 +143,13 @@ module psi_s_comm_a_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_sovrl_restrr1(x,xs,desc_a,info) - import + module subroutine psi_sovrl_restrr1(x,xs,desc_a,info) real(psb_spk_), intent(inout) :: x(:) real(psb_spk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_restrr1 - subroutine psi_sovrl_restrr2(x,xs,desc_a,info) - import + module subroutine psi_sovrl_restrr2(x,xs,desc_a,info) real(psb_spk_), intent(inout) :: x(:,:) real(psb_spk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a diff --git a/base/modules/comm/psi_s_comm_v_mod.f90 b/base/modules/comm/psi_s_comm_v_mod.f90 index 1cf4d53e..f210542a 100644 --- a/base/modules/comm/psi_s_comm_v_mod.f90 +++ b/base/modules/comm/psi_s_comm_v_mod.f90 @@ -36,8 +36,7 @@ module psi_s_comm_v_mod use psb_s_base_multivect_mod, only : psb_s_base_multivect_type interface psi_swapdata - subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_s_base_vect_type) :: y @@ -46,8 +45,7 @@ module psi_s_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_sswapdata_vect - subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_sswapdata_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_s_base_multivect_type) :: y @@ -56,11 +54,9 @@ module psi_s_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_sswapdata_multivect - subroutine psi_sswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_sswap_vidx_vect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_s_base_vect_type) :: y @@ -69,11 +65,9 @@ module psi_s_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_sswap_vidx_vect - subroutine psi_sswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_sswap_vidx_multivect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_s_base_multivect_type) :: y @@ -86,8 +80,7 @@ module psi_s_comm_v_mod interface psi_swaptran - subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_s_base_vect_type) :: y @@ -96,8 +89,7 @@ module psi_s_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_sswaptran_vect - subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_s_base_multivect_type) :: y @@ -106,11 +98,9 @@ module psi_s_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_sswaptran_multivect - subroutine psi_stran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_stran_vidx_vect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_s_base_vect_type) :: y @@ -119,11 +109,9 @@ module psi_s_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_stran_vidx_vect - subroutine psi_stran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_stran_vidx_multivect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_s_base_multivect_type) :: y @@ -135,15 +123,13 @@ module psi_s_comm_v_mod end interface psi_swaptran interface psi_ovrl_upd - subroutine psi_sovrl_upd_vect(x,desc_a,update,info) - import + module subroutine psi_sovrl_upd_vect(x,desc_a,update,info) class(psb_s_base_vect_type) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_upd_vect - subroutine psi_sovrl_upd_multivect(x,desc_a,update,info) - import + module subroutine psi_sovrl_upd_multivect(x,desc_a,update,info) class(psb_s_base_multivect_type) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update @@ -152,15 +138,13 @@ module psi_s_comm_v_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_sovrl_save_vect(x,xs,desc_a,info) - import + module subroutine psi_sovrl_save_vect(x,xs,desc_a,info) class(psb_s_base_vect_type) :: x real(psb_spk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_save_vect - subroutine psi_sovrl_save_multivect(x,xs,desc_a,info) - import + module subroutine psi_sovrl_save_multivect(x,xs,desc_a,info) class(psb_s_base_multivect_type) :: x real(psb_spk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -169,15 +153,13 @@ module psi_s_comm_v_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_sovrl_restr_vect(x,xs,desc_a,info) - import + module subroutine psi_sovrl_restr_vect(x,xs,desc_a,info) class(psb_s_base_vect_type) :: x real(psb_spk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_sovrl_restr_vect - subroutine psi_sovrl_restr_multivect(x,xs,desc_a,info) - import + module subroutine psi_sovrl_restr_multivect(x,xs,desc_a,info) class(psb_s_base_multivect_type) :: x real(psb_spk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a diff --git a/base/modules/comm/psi_z_comm_a_mod.f90 b/base/modules/comm/psi_z_comm_a_mod.f90 index 9f7477a1..28393467 100644 --- a/base/modules/comm/psi_z_comm_a_mod.f90 +++ b/base/modules/comm/psi_z_comm_a_mod.f90 @@ -34,8 +34,7 @@ module psi_z_comm_a_mod use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_dpk_, psb_i_base_vect_type interface psi_swapdata - subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) - import + module subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -44,8 +43,7 @@ module psi_z_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_zswapdatam - subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: y(:), beta @@ -53,11 +51,9 @@ module psi_z_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_zswapdatav - subroutine psi_zswapidxm(ctxt,icomm,flag,n,beta,y,idx,& + module subroutine psi_zswapidxm(ctxt,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -65,11 +61,9 @@ module psi_z_comm_a_mod complex(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_zswapidxm - subroutine psi_zswapidxv(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_zswapidxv(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_Mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: y(:), beta @@ -80,8 +74,7 @@ module psi_z_comm_a_mod interface psi_swaptran - subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) - import + module subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_Mpk_), intent(in) :: n integer(psb_ipk_), intent(out) :: info @@ -90,8 +83,7 @@ module psi_z_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_zswaptranm - subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: y(:), beta @@ -99,11 +91,9 @@ module psi_z_comm_a_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_zswaptranv - subroutine psi_ztranidxm(ctxt,icomm,flag,n,beta,y,idx,& + module subroutine psi_ztranidxm(ctxt,flag,n,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_mpk_), intent(in) :: n integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info @@ -111,11 +101,9 @@ module psi_z_comm_a_mod complex(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_ztranidxm - subroutine psi_ztranidxv(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_ztranidxv(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: y(:), beta @@ -123,17 +111,15 @@ module psi_z_comm_a_mod integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv end subroutine psi_ztranidxv end interface psi_swaptran - + interface psi_ovrl_upd - subroutine psi_zovrl_updr1(x,desc_a,update,info) - import + module subroutine psi_zovrl_updr1(x,desc_a,update,info) complex(psb_dpk_), intent(inout), target :: x(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_updr1 - subroutine psi_zovrl_updr2(x,desc_a,update,info) - import + module subroutine psi_zovrl_updr2(x,desc_a,update,info) complex(psb_dpk_), intent(inout), target :: x(:,:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update @@ -142,15 +128,13 @@ module psi_z_comm_a_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_zovrl_saver1(x,xs,desc_a,info) - import + module subroutine psi_zovrl_saver1(x,xs,desc_a,info) complex(psb_dpk_), intent(inout) :: x(:) complex(psb_dpk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_saver1 - subroutine psi_zovrl_saver2(x,xs,desc_a,info) - import + module subroutine psi_zovrl_saver2(x,xs,desc_a,info) complex(psb_dpk_), intent(inout) :: x(:,:) complex(psb_dpk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -159,15 +143,13 @@ module psi_z_comm_a_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_zovrl_restrr1(x,xs,desc_a,info) - import + module subroutine psi_zovrl_restrr1(x,xs,desc_a,info) complex(psb_dpk_), intent(inout) :: x(:) complex(psb_dpk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_restrr1 - subroutine psi_zovrl_restrr2(x,xs,desc_a,info) - import + module subroutine psi_zovrl_restrr2(x,xs,desc_a,info) complex(psb_dpk_), intent(inout) :: x(:,:) complex(psb_dpk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a diff --git a/base/modules/comm/psi_z_comm_v_mod.f90 b/base/modules/comm/psi_z_comm_v_mod.f90 index de8e1117..8c749f60 100644 --- a/base/modules/comm/psi_z_comm_v_mod.f90 +++ b/base/modules/comm/psi_z_comm_v_mod.f90 @@ -36,8 +36,7 @@ module psi_z_comm_v_mod use psb_z_base_multivect_mod, only : psb_z_base_multivect_type interface psi_swapdata - subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_z_base_vect_type) :: y @@ -46,8 +45,7 @@ module psi_z_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_zswapdata_vect - subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_zswapdata_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_z_base_multivect_type) :: y @@ -56,11 +54,9 @@ module psi_z_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_zswapdata_multivect - subroutine psi_zswap_vidx_vect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_zswap_vidx_vect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_z_base_vect_type) :: y @@ -69,11 +65,9 @@ module psi_z_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_zswap_vidx_vect - subroutine psi_zswap_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_zswap_vidx_multivect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_z_base_multivect_type) :: y @@ -86,8 +80,7 @@ module psi_z_comm_v_mod interface psi_swaptran - subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_z_base_vect_type) :: y @@ -96,8 +89,7 @@ module psi_z_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_zswaptran_vect - subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data) - import + module subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_z_base_multivect_type) :: y @@ -106,11 +98,9 @@ module psi_z_comm_v_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_zswaptran_multivect - subroutine psi_ztran_vidx_vect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_ztran_vidx_vect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_z_base_vect_type) :: y @@ -119,11 +109,9 @@ module psi_z_comm_v_mod class(psb_i_base_vect_type), intent(inout) :: idx integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv end subroutine psi_ztran_vidx_vect - subroutine psi_ztran_vidx_multivect(ctxt,icomm,flag,beta,y,idx,& + module subroutine psi_ztran_vidx_multivect(ctxt,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) - import type(psb_ctxt_type), intent(in) :: ctxt - integer(psb_mpk_), intent(in) :: icomm integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info class(psb_z_base_multivect_type) :: y @@ -135,15 +123,13 @@ module psi_z_comm_v_mod end interface psi_swaptran interface psi_ovrl_upd - subroutine psi_zovrl_upd_vect(x,desc_a,update,info) - import + module subroutine psi_zovrl_upd_vect(x,desc_a,update,info) class(psb_z_base_vect_type) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_upd_vect - subroutine psi_zovrl_upd_multivect(x,desc_a,update,info) - import + module subroutine psi_zovrl_upd_multivect(x,desc_a,update,info) class(psb_z_base_multivect_type) :: x type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: update @@ -152,15 +138,13 @@ module psi_z_comm_v_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_zovrl_save_vect(x,xs,desc_a,info) - import + module subroutine psi_zovrl_save_vect(x,xs,desc_a,info) class(psb_z_base_vect_type) :: x complex(psb_dpk_), allocatable :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_save_vect - subroutine psi_zovrl_save_multivect(x,xs,desc_a,info) - import + module subroutine psi_zovrl_save_multivect(x,xs,desc_a,info) class(psb_z_base_multivect_type) :: x complex(psb_dpk_), allocatable :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a @@ -169,15 +153,13 @@ module psi_z_comm_v_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_zovrl_restr_vect(x,xs,desc_a,info) - import + module subroutine psi_zovrl_restr_vect(x,xs,desc_a,info) class(psb_z_base_vect_type) :: x complex(psb_dpk_) :: xs(:) type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psi_zovrl_restr_vect - subroutine psi_zovrl_restr_multivect(x,xs,desc_a,info) - import + module subroutine psi_zovrl_restr_multivect(x,xs,desc_a,info) class(psb_z_base_multivect_type) :: x complex(psb_dpk_) :: xs(:,:) type(psb_desc_type), intent(in) :: desc_a