diff --git a/base/comm/internals/psi_dswapdata.F90 b/base/comm/internals/psi_dswapdata.F90 index c5c043e6..19ce72a2 100644 --- a/base/comm/internals/psi_dswapdata.F90 +++ b/base/comm/internals/psi_dswapdata.F90 @@ -113,7 +113,6 @@ contains type(psb_ctxt_type) :: ctxt integer(psb_ipk_) :: np, me, total_send, total_recv, num_neighbors, data_, err_act class(psb_i_base_vect_type), pointer :: comm_indexes - character(len=20) :: name ! local variables used to detect the communication scheme logical :: swap_mpi, swap_sync, swap_send, swap_recv, swap_start, swap_wait @@ -631,7 +630,7 @@ contains integer(psb_mpk_) :: icomm integer(psb_ipk_) :: np, me, total_send, total_recv, num_neighbors, data_, err_act class(psb_i_base_vect_type), pointer :: comm_indexes - character(len=20) :: name + character(len=30) :: name info = psb_success_ name = 'psi_dswapdata_multivect' diff --git a/base/comm/internals/psi_sswapdata.F90 b/base/comm/internals/psi_sswapdata.F90 index c4cfbf05..4718c3e3 100644 --- a/base/comm/internals/psi_sswapdata.F90 +++ b/base/comm/internals/psi_sswapdata.F90 @@ -105,25 +105,34 @@ contains integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info - class(psb_s_base_vect_type) :: y - real(psb_spk_), intent(in) :: beta - real(psb_spk_), target :: work(:) - type(psb_desc_type), target :: desc_a + class(psb_s_base_vect_type) :: y + real(psb_spk_), intent(in) :: beta + type(psb_desc_type), target :: desc_a + real(psb_spk_), target :: work(:) 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 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, total_send, total_recv, num_neighbors, data_, err_act + class(psb_i_base_vect_type), pointer :: comm_indexes + + + ! local variables used to detect the communication scheme + logical :: swap_mpi, swap_sync, swap_send, swap_recv, swap_start, swap_wait + logical :: baseline, neighbor_a2av + + ! error handling variables + integer(psb_ipk_) :: err_act + integer(psb_mpk_) :: me, np + character(len=30) :: name + info=psb_success_ - name='psi_swap_datav' + name='psi_sswapdata_vect' 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_ @@ -149,122 +158,50 @@ contains 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 - -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) + 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 + swap_start = iand(flag,psb_swap_start_) /= 0 + swap_wait = iand(flag,psb_swap_wait_) /= 0 + baseline = swap_mpi .or. swap_send .or. swap_recv .or. swap_sync + neighbor_a2av = swap_start .or. swap_wait -#ifdef PSB_MPI_MOD - use mpi -#endif - implicit none -#ifdef PSB_MPI_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_), intent(in) :: beta - real(psb_spk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! local variables used to detect the communication scheme - logical :: swap_mpi, swap_sync, swap_send, swap_recv, swap_start, swap_wait - logical :: baseline, neighbor_a2av - - ! local variable used for get the communicator - integer(psb_mpk_) :: icomm - - ! error handling variables - integer(psb_ipk_) :: err_act - integer(psb_mpk_) :: me, np - character(len=30) :: name - - - info=psb_success_ - name='psi_sswap_vidx_vect' - 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 - swap_start = iand(flag,psb_swap_start_) /= 0 - swap_wait = iand(flag,psb_swap_wait_) /= 0 - - baseline = swap_mpi .or. swap_send .or. swap_recv .or. swap_sync - neighbor_a2av = swap_start .or. swap_wait - - icomm = ctxt%get_mpic() - - if( (baseline.eqv..true.).and.(neighbor_a2av.eqv..true.) ) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,a_err='Incompatible flag settings: both baseline and neighbor_a2av are true') - goto 9999 - end if - - - if (baseline) then - call psi_sswap_baseline_vect(ctxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) - if (info /= psb_success_) then - call psb_errpush(info,name,a_err='baseline swap') + if( (baseline.eqv..true.).and.(neighbor_a2av.eqv..true.) ) then + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Incompatible flag settings: both baseline and neighbor_a2av are true') goto 9999 end if - else if (neighbor_a2av) then - call psi_sswap_neighbor_topology_vect(ctxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) - if (info /= psb_success_) then - call psb_errpush(info,name,a_err='neighbor a2av swap') + + if (baseline) then + call psi_dswap_baseline_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline swap') + goto 9999 + end if + else if (neighbor_a2av) then + call psi_dswap_neighbor_topology_vect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor a2av swap') + goto 9999 + end if + else + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Incompatible flag settings: neither baseline nor neighbor_a2av is true') goto 9999 end if - else - info = psb_err_mpi_error_ - call psb_errpush(info,name,a_err='Incompatible flag settings: neither baseline nor neighbor_a2av is true') - 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 + return + end subroutine psi_sswapdata_vect + - end subroutine psi_sswap_vidx_vect @@ -694,25 +631,30 @@ end subroutine psi_sswap_neighbor_topology_vect integer(psb_ipk_), intent(in) :: flag integer(psb_ipk_), intent(out) :: info - class(psb_s_base_multivect_type) :: y - real(psb_spk_), intent(in) :: beta - real(psb_spk_), target :: work(:) - type(psb_desc_type), target :: desc_a + class(psb_s_base_multivect_type) :: y + real(psb_spk_), intent(in) :: beta + type(psb_desc_type), target :: desc_a + real(psb_spk_), target :: work(:) 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 + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, total_send, total_recv, num_neighbors, data_, err_act + class(psb_i_base_vect_type), pointer :: comm_indexes + character(len=30) :: name + + ! local variables used to detect the communication scheme + logical :: swap_mpi, swap_sync, swap_send, swap_recv, swap_start, swap_wait + logical :: baseline, neighbor_a2av + info=psb_success_ - name='psi_swap_datav' + name='psi_sswapdata_multivect' 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_ @@ -738,120 +680,52 @@ end subroutine psi_sswap_neighbor_topology_vect 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 - -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) -#ifdef PSB_MPI_MOD - use mpi -#endif - implicit none -#ifdef PSB_MPI_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_), intent(in) :: beta - real(psb_spk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - - ! local variables used to detect the communication scheme - logical :: swap_mpi, swap_sync, swap_send, swap_recv, swap_start, swap_wait - logical :: baseline, neighbor_a2av + 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 + swap_start = iand(flag,psb_swap_start_) /= 0 + swap_wait = iand(flag,psb_swap_wait_) /= 0 - ! local variable used to get communicator - integer(psb_mpk_) :: icomm - - ! error handling variables - integer(psb_ipk_) :: err_act - integer(psb_mpk_) :: me, np - character(len=30) :: name - - - info=psb_success_ - name='psi_sswap_vidx_multivect' - 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 - swap_start = iand(flag,psb_swap_start_) /= 0 - swap_wait = iand(flag,psb_swap_wait_) /= 0 - - baseline = swap_mpi .or. swap_send .or. swap_recv .or. swap_sync - neighbor_a2av = swap_start .or. swap_wait - - icomm = ctxt%get_mpic() - - if( (baseline.eqv..true.).and.(neighbor_a2av.eqv..true.) ) then - info=psb_err_mpi_error_ - call psb_errpush(info,name,a_err='Incompatible flag settings: both baseline and neighbor_a2av are true') - goto 9999 - end if + baseline = swap_mpi .or. swap_send .or. swap_recv .or. swap_sync + neighbor_a2av = swap_start .or. swap_wait + icomm = ctxt%get_mpic() - if (baseline) then - call psi_sswap_baseline_multivect(ctxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) - if (info /= psb_success_) then - call psb_errpush(info,name,a_err='baseline swap') + if( (baseline.eqv..true.).and.(neighbor_a2av.eqv..true.) ) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Incompatible flag settings: both baseline and neighbor_a2av are true') goto 9999 end if - else if (neighbor_a2av) then - call psi_sswap_neighbor_topology_multivect(ctxt,icomm,flag,beta,y,idx,totxch,totsnd,totrcv,work,info) - if (info /= psb_success_) then - call psb_errpush(info,name,a_err='neighbor a2av swap') + + + if (baseline) then + call psi_dswap_baseline_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='baseline swap') + goto 9999 + end if + else if (neighbor_a2av) then + call psi_dswap_neighbor_topology_multivect(ctxt,flag,beta,y,comm_indexes,num_neighbors,total_send,total_recv,info) + if (info /= psb_success_) then + call psb_errpush(info,name,a_err='neighbor a2av swap') + goto 9999 + end if + else + info = psb_err_mpi_error_ + call psb_errpush(info,name,a_err='Incompatible flag settings: neither baseline nor neighbor_a2av is true') goto 9999 end if - else - info = psb_err_mpi_error_ - call psb_errpush(info,name,a_err='Incompatible flag settings: neither baseline nor neighbor_a2av is true') - 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 + return + end subroutine psi_sswapdata_multivect + - end subroutine psi_sswap_vidx_multivect diff --git a/base/modules/comm/psi_s_comm_v_mod.f90 b/base/modules/comm/psi_s_comm_v_mod.f90 index 170e7c91..ccd114cc 100644 --- a/base/modules/comm/psi_s_comm_v_mod.f90 +++ b/base/modules/comm/psi_s_comm_v_mod.f90 @@ -39,46 +39,25 @@ module psi_s_comm_v_mod 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 - real(psb_spk_), intent(in) :: beta - real(psb_spk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data + class(psb_s_base_vect_type) :: y + real(psb_spk_), intent(in) :: beta + real(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data end subroutine psi_sswapdata_vect 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 - real(psb_spk_), intent(in) :: beta - real(psb_spk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data + class(psb_s_base_multivect_type) :: y + real(psb_spk_), intent(in) :: beta + real(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data end subroutine psi_sswapdata_multivect - module subroutine psi_sswap_vidx_vect(ctxt,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - 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_), intent(in) :: beta - real(psb_spk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - end subroutine psi_sswap_vidx_vect - module subroutine psi_sswap_vidx_multivect(ctxt,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - 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_), intent(in) :: beta - real(psb_spk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - end subroutine psi_sswap_vidx_multivect end interface psi_swapdata + interface psi_swaptran module subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data) integer(psb_ipk_), intent(in) :: flag