diff --git a/base/comm/internals/psi_cswapdata.F90 b/base/comm/internals/psi_cswapdata.F90 index 72b97a987..f11f9b9e4 100644 --- a/base/comm/internals/psi_cswapdata.F90 +++ b/base/comm/internals/psi_cswapdata.F90 @@ -118,11 +118,14 @@ contains ! error handling variables integer(psb_ipk_) :: err_act character(len=30) :: name + logical :: debug info = psb_success_ name = 'psi_cswapdata_vect' call psb_erractionsave(err_act) + debug = .false. + ctxt = desc_a%get_context() call psb_info(ctxt,my_rank,np) @@ -159,7 +162,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 @@ -173,7 +176,9 @@ contains goto 9999 end if - + if(debug .eqv. .true.) then + write(0,'(a,i0,a,i0)') 'DBG_DISPATCH comm_type=',y%comm_handle%comm_type,' desc_a%comm_type=',desc_a%comm_type + endif select case(y%comm_handle%comm_type) case(psb_comm_isend_irecv_) call psi_cswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) @@ -620,15 +625,15 @@ contains if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Ineighbor_alltoallv' if (buffer_size > 0) then call mpi_ineighbor_alltoallv( & - & y%combuf(1), & ! send buffer - & n*neighbor_comm_handle%send_counts, & - & n*neighbor_comm_handle%send_displs, & - & psb_mpi_r_dpk_, & - & y%combuf(1), & ! recv buffer (baseline layout) - & neighbor_comm_handle%recv_counts, & - & neighbor_comm_handle%recv_displs, & - & psb_mpi_r_dpk_, & - & neighbor_comm_handle%graph_comm, & + & y%combuf(1), & ! send buffer (baseline/positional layout) + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs_v, & ! positional displacements (match gth layout) + & psb_mpi_r_spk_, & + & y%combuf(1), & ! recv buffer (baseline/positional layout) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs_v, & ! positional displacements (match sct layout) + & psb_mpi_r_spk_, & + & neighbor_comm_handle%graph_comm, & & neighbor_comm_handle%comm_request, iret) if (iret /= mpi_success) then info = psb_err_mpi_error_ @@ -756,6 +761,7 @@ contains integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n info = psb_success_ + debug = .false. name = 'psi_cswap_neighbor_persistent_topology_vect' call psb_erractionsave(err_act) call psb_info(ctxt,my_rank,np) @@ -825,12 +831,12 @@ contains neighbor_comm_handle%persistent_in_flight = .false. neighbor_comm_handle%persistent_buffer_size = 0 end if - call y%new_buffer(buffer_size, info) + call y%new_buffer(ione*size(comm_indexes%v), info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - else if (size(y%combuf) < buffer_size) then + else if (size(y%combuf) < ione*size(comm_indexes%v)) then if (neighbor_comm_handle%persistent_request_ready) then if (neighbor_comm_handle%persistent_request /= mpi_request_null) then call mpi_request_free(neighbor_comm_handle%persistent_request, iret) @@ -840,7 +846,7 @@ contains neighbor_comm_handle%persistent_in_flight = .false. neighbor_comm_handle%persistent_buffer_size = 0 end if - call y%new_buffer(buffer_size, info) + call y%new_buffer(ione*size(comm_indexes%v), info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 @@ -882,16 +888,16 @@ contains if (buffer_size > 0) then if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Neighbor_alltoallv_init' call mpi_neighbor_alltoallv_init( & - & y%combuf(1), & ! send buffer - & neighbor_comm_handle%send_counts, & - & neighbor_comm_handle%send_displs, & - & psb_mpi_r_dpk_, & - & y%combuf(1), & ! recv buffer (baseline layout) - & neighbor_comm_handle%recv_counts, & - & neighbor_comm_handle%recv_displs, & - & psb_mpi_r_dpk_, & - & neighbor_comm_handle%graph_comm, & - & mpi_info_null, & + & y%combuf(1), & ! send buffer + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs_v, & ! positional (baseline layout) + & psb_mpi_r_dpk_, & + & y%combuf(1), & ! recv buffer (baseline layout) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs_v, & ! positional (baseline layout) + & psb_mpi_r_dpk_, & + & neighbor_comm_handle%graph_comm, & + & mpi_info_null, & & neighbor_comm_handle%persistent_request, iret) if (iret /= mpi_success) then info = psb_err_mpi_error_ @@ -1559,7 +1565,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 diff --git a/base/comm/internals/psi_cswaptran.F90 b/base/comm/internals/psi_cswaptran.F90 index ca390eccd..a030bbe17 100644 --- a/base/comm/internals/psi_cswaptran.F90 +++ b/base/comm/internals/psi_cswaptran.F90 @@ -157,7 +157,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 @@ -745,7 +745,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 diff --git a/base/comm/internals/psi_dswapdata.F90 b/base/comm/internals/psi_dswapdata.F90 index 922bff293..e2516df29 100644 --- a/base/comm/internals/psi_dswapdata.F90 +++ b/base/comm/internals/psi_dswapdata.F90 @@ -118,11 +118,14 @@ contains ! error handling variables integer(psb_ipk_) :: err_act character(len=30) :: name + logical :: debug info = psb_success_ name = 'psi_dswapdata_vect' call psb_erractionsave(err_act) + debug = .false. + ctxt = desc_a%get_context() call psb_info(ctxt,my_rank,np) @@ -159,7 +162,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 @@ -173,7 +176,9 @@ contains goto 9999 end if - + if(debug .eqv. .true.) then + write(0,'(a,i0,a,i0)') 'DBG_DISPATCH comm_type=',y%comm_handle%comm_type,' desc_a%comm_type=',desc_a%comm_type + endif select case(y%comm_handle%comm_type) case(psb_comm_isend_irecv_) call psi_dswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) @@ -620,15 +625,15 @@ contains if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Ineighbor_alltoallv' if (buffer_size > 0) then call mpi_ineighbor_alltoallv( & - & y%combuf(1), & ! send buffer - & n*neighbor_comm_handle%send_counts, & - & n*neighbor_comm_handle%send_displs, & - & psb_mpi_r_dpk_, & - & y%combuf(1), & ! recv buffer (baseline layout) - & neighbor_comm_handle%recv_counts, & - & neighbor_comm_handle%recv_displs, & - & psb_mpi_r_dpk_, & - & neighbor_comm_handle%graph_comm, & + & y%combuf(1), & ! send buffer (baseline/positional layout) + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs_v, & ! positional displacements (match gth layout) + & psb_mpi_r_dpk_, & + & y%combuf(1), & ! recv buffer (baseline/positional layout) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs_v, & ! positional displacements (match sct layout) + & psb_mpi_r_dpk_, & + & neighbor_comm_handle%graph_comm, & & neighbor_comm_handle%comm_request, iret) if (iret /= mpi_success) then info = psb_err_mpi_error_ @@ -756,6 +761,7 @@ contains integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n info = psb_success_ + debug = .false. name = 'psi_dswap_neighbor_persistent_topology_vect' call psb_erractionsave(err_act) call psb_info(ctxt,my_rank,np) @@ -825,12 +831,12 @@ contains neighbor_comm_handle%persistent_in_flight = .false. neighbor_comm_handle%persistent_buffer_size = 0 end if - call y%new_buffer(buffer_size, info) + call y%new_buffer(ione*size(comm_indexes%v), info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - else if (size(y%combuf) < buffer_size) then + else if (size(y%combuf) < ione*size(comm_indexes%v)) then if (neighbor_comm_handle%persistent_request_ready) then if (neighbor_comm_handle%persistent_request /= mpi_request_null) then call mpi_request_free(neighbor_comm_handle%persistent_request, iret) @@ -840,7 +846,7 @@ contains neighbor_comm_handle%persistent_in_flight = .false. neighbor_comm_handle%persistent_buffer_size = 0 end if - call y%new_buffer(buffer_size, info) + call y%new_buffer(ione*size(comm_indexes%v), info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 @@ -882,16 +888,16 @@ contains if (buffer_size > 0) then if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Neighbor_alltoallv_init' call mpi_neighbor_alltoallv_init( & - & y%combuf(1), & ! send buffer - & neighbor_comm_handle%send_counts, & - & neighbor_comm_handle%send_displs, & - & psb_mpi_r_dpk_, & - & y%combuf(1), & ! recv buffer (baseline layout) - & neighbor_comm_handle%recv_counts, & - & neighbor_comm_handle%recv_displs, & - & psb_mpi_r_dpk_, & - & neighbor_comm_handle%graph_comm, & - & mpi_info_null, & + & y%combuf(1), & ! send buffer + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs_v, & ! positional (baseline layout) + & psb_mpi_r_dpk_, & + & y%combuf(1), & ! recv buffer (baseline layout) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs_v, & ! positional (baseline layout) + & psb_mpi_r_dpk_, & + & neighbor_comm_handle%graph_comm, & + & mpi_info_null, & & neighbor_comm_handle%persistent_request, iret) if (iret /= mpi_success) then info = psb_err_mpi_error_ @@ -1559,7 +1565,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 diff --git a/base/comm/internals/psi_dswaptran.F90 b/base/comm/internals/psi_dswaptran.F90 index f16a944fa..6046591b9 100644 --- a/base/comm/internals/psi_dswaptran.F90 +++ b/base/comm/internals/psi_dswaptran.F90 @@ -157,7 +157,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 @@ -745,7 +745,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 diff --git a/base/comm/internals/psi_iswapdata.F90 b/base/comm/internals/psi_iswapdata.F90 index 43cd54c40..454cc9917 100644 --- a/base/comm/internals/psi_iswapdata.F90 +++ b/base/comm/internals/psi_iswapdata.F90 @@ -118,11 +118,14 @@ contains ! error handling variables integer(psb_ipk_) :: err_act character(len=30) :: name + logical :: debug info = psb_success_ name = 'psi_iswapdata_vect' call psb_erractionsave(err_act) + debug = .false. + ctxt = desc_a%get_context() call psb_info(ctxt,my_rank,np) @@ -159,7 +162,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 @@ -173,7 +176,9 @@ contains goto 9999 end if - + if(debug .eqv. .true.) then + write(0,'(a,i0,a,i0)') 'DBG_DISPATCH comm_type=',y%comm_handle%comm_type,' desc_a%comm_type=',desc_a%comm_type + endif select case(y%comm_handle%comm_type) case(psb_comm_isend_irecv_) call psi_iswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) @@ -620,15 +625,15 @@ contains if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Ineighbor_alltoallv' if (buffer_size > 0) then call mpi_ineighbor_alltoallv( & - & y%combuf(1), & ! send buffer - & n*neighbor_comm_handle%send_counts, & - & n*neighbor_comm_handle%send_displs, & - & psb_mpi_r_dpk_, & - & y%combuf(1), & ! recv buffer (baseline layout) - & neighbor_comm_handle%recv_counts, & - & neighbor_comm_handle%recv_displs, & - & psb_mpi_r_dpk_, & - & neighbor_comm_handle%graph_comm, & + & y%combuf(1), & ! send buffer (baseline/positional layout) + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs_v, & ! positional displacements (match gth layout) + & psb_mpi_ipk_, & + & y%combuf(1), & ! recv buffer (baseline/positional layout) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs_v, & ! positional displacements (match sct layout) + & psb_mpi_ipk_, & + & neighbor_comm_handle%graph_comm, & & neighbor_comm_handle%comm_request, iret) if (iret /= mpi_success) then info = psb_err_mpi_error_ @@ -756,6 +761,7 @@ contains integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n info = psb_success_ + debug = .false. name = 'psi_iswap_neighbor_persistent_topology_vect' call psb_erractionsave(err_act) call psb_info(ctxt,my_rank,np) @@ -825,12 +831,12 @@ contains neighbor_comm_handle%persistent_in_flight = .false. neighbor_comm_handle%persistent_buffer_size = 0 end if - call y%new_buffer(buffer_size, info) + call y%new_buffer(ione*size(comm_indexes%v), info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - else if (size(y%combuf) < buffer_size) then + else if (size(y%combuf) < ione*size(comm_indexes%v)) then if (neighbor_comm_handle%persistent_request_ready) then if (neighbor_comm_handle%persistent_request /= mpi_request_null) then call mpi_request_free(neighbor_comm_handle%persistent_request, iret) @@ -840,7 +846,7 @@ contains neighbor_comm_handle%persistent_in_flight = .false. neighbor_comm_handle%persistent_buffer_size = 0 end if - call y%new_buffer(buffer_size, info) + call y%new_buffer(ione*size(comm_indexes%v), info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 @@ -882,16 +888,16 @@ contains if (buffer_size > 0) then if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Neighbor_alltoallv_init' call mpi_neighbor_alltoallv_init( & - & y%combuf(1), & ! send buffer - & neighbor_comm_handle%send_counts, & - & neighbor_comm_handle%send_displs, & - & psb_mpi_r_dpk_, & - & y%combuf(1), & ! recv buffer (baseline layout) - & neighbor_comm_handle%recv_counts, & - & neighbor_comm_handle%recv_displs, & - & psb_mpi_r_dpk_, & - & neighbor_comm_handle%graph_comm, & - & mpi_info_null, & + & y%combuf(1), & ! send buffer + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs_v, & ! positional (baseline layout) + & psb_mpi_r_dpk_, & + & y%combuf(1), & ! recv buffer (baseline layout) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs_v, & ! positional (baseline layout) + & psb_mpi_r_dpk_, & + & neighbor_comm_handle%graph_comm, & + & mpi_info_null, & & neighbor_comm_handle%persistent_request, iret) if (iret /= mpi_success) then info = psb_err_mpi_error_ @@ -1559,7 +1565,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 diff --git a/base/comm/internals/psi_iswaptran.F90 b/base/comm/internals/psi_iswaptran.F90 index 4b7f7ffb7..d99c7ca00 100644 --- a/base/comm/internals/psi_iswaptran.F90 +++ b/base/comm/internals/psi_iswaptran.F90 @@ -157,7 +157,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 @@ -745,7 +745,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 diff --git a/base/comm/internals/psi_lswapdata.F90 b/base/comm/internals/psi_lswapdata.F90 index d5b6efed7..bbc689468 100644 --- a/base/comm/internals/psi_lswapdata.F90 +++ b/base/comm/internals/psi_lswapdata.F90 @@ -118,11 +118,14 @@ contains ! error handling variables integer(psb_ipk_) :: err_act character(len=30) :: name + logical :: debug info = psb_success_ name = 'psi_lswapdata_vect' call psb_erractionsave(err_act) + debug = .false. + ctxt = desc_a%get_context() call psb_info(ctxt,my_rank,np) @@ -159,7 +162,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 @@ -173,7 +176,9 @@ contains goto 9999 end if - + if(debug .eqv. .true.) then + write(0,'(a,i0,a,i0)') 'DBG_DISPATCH comm_type=',y%comm_handle%comm_type,' desc_a%comm_type=',desc_a%comm_type + endif select case(y%comm_handle%comm_type) case(psb_comm_isend_irecv_) call psi_lswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) @@ -620,15 +625,15 @@ contains if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Ineighbor_alltoallv' if (buffer_size > 0) then call mpi_ineighbor_alltoallv( & - & y%combuf(1), & ! send buffer - & n*neighbor_comm_handle%send_counts, & - & n*neighbor_comm_handle%send_displs, & - & psb_mpi_r_dpk_, & - & y%combuf(1), & ! recv buffer (baseline layout) - & neighbor_comm_handle%recv_counts, & - & neighbor_comm_handle%recv_displs, & - & psb_mpi_r_dpk_, & - & neighbor_comm_handle%graph_comm, & + & y%combuf(1), & ! send buffer (baseline/positional layout) + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs_v, & ! positional displacements (match gth layout) + & psb_mpi_lpk_, & + & y%combuf(1), & ! recv buffer (baseline/positional layout) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs_v, & ! positional displacements (match sct layout) + & psb_mpi_lpk_, & + & neighbor_comm_handle%graph_comm, & & neighbor_comm_handle%comm_request, iret) if (iret /= mpi_success) then info = psb_err_mpi_error_ @@ -756,6 +761,7 @@ contains integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n info = psb_success_ + debug = .false. name = 'psi_lswap_neighbor_persistent_topology_vect' call psb_erractionsave(err_act) call psb_info(ctxt,my_rank,np) @@ -825,12 +831,12 @@ contains neighbor_comm_handle%persistent_in_flight = .false. neighbor_comm_handle%persistent_buffer_size = 0 end if - call y%new_buffer(buffer_size, info) + call y%new_buffer(ione*size(comm_indexes%v), info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - else if (size(y%combuf) < buffer_size) then + else if (size(y%combuf) < ione*size(comm_indexes%v)) then if (neighbor_comm_handle%persistent_request_ready) then if (neighbor_comm_handle%persistent_request /= mpi_request_null) then call mpi_request_free(neighbor_comm_handle%persistent_request, iret) @@ -840,7 +846,7 @@ contains neighbor_comm_handle%persistent_in_flight = .false. neighbor_comm_handle%persistent_buffer_size = 0 end if - call y%new_buffer(buffer_size, info) + call y%new_buffer(ione*size(comm_indexes%v), info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 @@ -882,16 +888,16 @@ contains if (buffer_size > 0) then if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Neighbor_alltoallv_init' call mpi_neighbor_alltoallv_init( & - & y%combuf(1), & ! send buffer - & neighbor_comm_handle%send_counts, & - & neighbor_comm_handle%send_displs, & - & psb_mpi_r_dpk_, & - & y%combuf(1), & ! recv buffer (baseline layout) - & neighbor_comm_handle%recv_counts, & - & neighbor_comm_handle%recv_displs, & - & psb_mpi_r_dpk_, & - & neighbor_comm_handle%graph_comm, & - & mpi_info_null, & + & y%combuf(1), & ! send buffer + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs_v, & ! positional (baseline layout) + & psb_mpi_r_dpk_, & + & y%combuf(1), & ! recv buffer (baseline layout) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs_v, & ! positional (baseline layout) + & psb_mpi_r_dpk_, & + & neighbor_comm_handle%graph_comm, & + & mpi_info_null, & & neighbor_comm_handle%persistent_request, iret) if (iret /= mpi_success) then info = psb_err_mpi_error_ @@ -1559,7 +1565,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 diff --git a/base/comm/internals/psi_lswaptran.F90 b/base/comm/internals/psi_lswaptran.F90 index 638dadf3a..818dedaf8 100644 --- a/base/comm/internals/psi_lswaptran.F90 +++ b/base/comm/internals/psi_lswaptran.F90 @@ -157,7 +157,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 @@ -745,7 +745,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 diff --git a/base/comm/internals/psi_sswapdata.F90 b/base/comm/internals/psi_sswapdata.F90 index d5e54af42..015506959 100644 --- a/base/comm/internals/psi_sswapdata.F90 +++ b/base/comm/internals/psi_sswapdata.F90 @@ -118,11 +118,14 @@ contains ! error handling variables integer(psb_ipk_) :: err_act character(len=30) :: name + logical :: debug info = psb_success_ name = 'psi_sswapdata_vect' call psb_erractionsave(err_act) + debug = .false. + ctxt = desc_a%get_context() call psb_info(ctxt,my_rank,np) @@ -159,7 +162,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 @@ -173,7 +176,9 @@ contains goto 9999 end if - + if(debug .eqv. .true.) then + write(0,'(a,i0,a,i0)') 'DBG_DISPATCH comm_type=',y%comm_handle%comm_type,' desc_a%comm_type=',desc_a%comm_type + endif select case(y%comm_handle%comm_type) case(psb_comm_isend_irecv_) call psi_sswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) @@ -620,15 +625,15 @@ contains if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Ineighbor_alltoallv' if (buffer_size > 0) then call mpi_ineighbor_alltoallv( & - & y%combuf(1), & ! send buffer - & n*neighbor_comm_handle%send_counts, & - & n*neighbor_comm_handle%send_displs, & - & psb_mpi_r_dpk_, & - & y%combuf(1), & ! recv buffer (baseline layout) - & neighbor_comm_handle%recv_counts, & - & neighbor_comm_handle%recv_displs, & - & psb_mpi_r_dpk_, & - & neighbor_comm_handle%graph_comm, & + & y%combuf(1), & ! send buffer (baseline/positional layout) + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs_v, & ! positional displacements (match gth layout) + & psb_mpi_r_spk_, & + & y%combuf(1), & ! recv buffer (baseline/positional layout) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs_v, & ! positional displacements (match sct layout) + & psb_mpi_r_spk_, & + & neighbor_comm_handle%graph_comm, & & neighbor_comm_handle%comm_request, iret) if (iret /= mpi_success) then info = psb_err_mpi_error_ @@ -756,6 +761,7 @@ contains integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n info = psb_success_ + debug = .false. name = 'psi_sswap_neighbor_persistent_topology_vect' call psb_erractionsave(err_act) call psb_info(ctxt,my_rank,np) @@ -825,12 +831,12 @@ contains neighbor_comm_handle%persistent_in_flight = .false. neighbor_comm_handle%persistent_buffer_size = 0 end if - call y%new_buffer(buffer_size, info) + call y%new_buffer(ione*size(comm_indexes%v), info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - else if (size(y%combuf) < buffer_size) then + else if (size(y%combuf) < ione*size(comm_indexes%v)) then if (neighbor_comm_handle%persistent_request_ready) then if (neighbor_comm_handle%persistent_request /= mpi_request_null) then call mpi_request_free(neighbor_comm_handle%persistent_request, iret) @@ -840,7 +846,7 @@ contains neighbor_comm_handle%persistent_in_flight = .false. neighbor_comm_handle%persistent_buffer_size = 0 end if - call y%new_buffer(buffer_size, info) + call y%new_buffer(ione*size(comm_indexes%v), info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 @@ -882,16 +888,16 @@ contains if (buffer_size > 0) then if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Neighbor_alltoallv_init' call mpi_neighbor_alltoallv_init( & - & y%combuf(1), & ! send buffer - & neighbor_comm_handle%send_counts, & - & neighbor_comm_handle%send_displs, & - & psb_mpi_r_dpk_, & - & y%combuf(1), & ! recv buffer (baseline layout) - & neighbor_comm_handle%recv_counts, & - & neighbor_comm_handle%recv_displs, & - & psb_mpi_r_dpk_, & - & neighbor_comm_handle%graph_comm, & - & mpi_info_null, & + & y%combuf(1), & ! send buffer + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs_v, & ! positional (baseline layout) + & psb_mpi_r_dpk_, & + & y%combuf(1), & ! recv buffer (baseline layout) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs_v, & ! positional (baseline layout) + & psb_mpi_r_dpk_, & + & neighbor_comm_handle%graph_comm, & + & mpi_info_null, & & neighbor_comm_handle%persistent_request, iret) if (iret /= mpi_success) then info = psb_err_mpi_error_ @@ -1559,7 +1565,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 diff --git a/base/comm/internals/psi_sswaptran.F90 b/base/comm/internals/psi_sswaptran.F90 index 8b47a2988..8c7f8e828 100644 --- a/base/comm/internals/psi_sswaptran.F90 +++ b/base/comm/internals/psi_sswaptran.F90 @@ -157,7 +157,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 @@ -745,7 +745,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 diff --git a/base/comm/internals/psi_zswapdata.F90 b/base/comm/internals/psi_zswapdata.F90 index 5223ec5c8..62365a52f 100644 --- a/base/comm/internals/psi_zswapdata.F90 +++ b/base/comm/internals/psi_zswapdata.F90 @@ -118,11 +118,14 @@ contains ! error handling variables integer(psb_ipk_) :: err_act character(len=30) :: name + logical :: debug info = psb_success_ name = 'psi_zswapdata_vect' call psb_erractionsave(err_act) + debug = .false. + ctxt = desc_a%get_context() call psb_info(ctxt,my_rank,np) @@ -159,7 +162,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 @@ -173,7 +176,9 @@ contains goto 9999 end if - + if(debug .eqv. .true.) then + write(0,'(a,i0,a,i0)') 'DBG_DISPATCH comm_type=',y%comm_handle%comm_type,' desc_a%comm_type=',desc_a%comm_type + endif select case(y%comm_handle%comm_type) case(psb_comm_isend_irecv_) call psi_zswap_baseline_vect(ctxt,swap_status,beta,y,comm_indexes,num_neighbors,total_send,total_recv,y%comm_handle,info) @@ -620,15 +625,15 @@ contains if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Ineighbor_alltoallv' if (buffer_size > 0) then call mpi_ineighbor_alltoallv( & - & y%combuf(1), & ! send buffer - & n*neighbor_comm_handle%send_counts, & - & n*neighbor_comm_handle%send_displs, & - & psb_mpi_r_dpk_, & - & y%combuf(1), & ! recv buffer (baseline layout) - & neighbor_comm_handle%recv_counts, & - & neighbor_comm_handle%recv_displs, & - & psb_mpi_r_dpk_, & - & neighbor_comm_handle%graph_comm, & + & y%combuf(1), & ! send buffer (baseline/positional layout) + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs_v, & ! positional displacements (match gth layout) + & psb_mpi_r_dpk_, & + & y%combuf(1), & ! recv buffer (baseline/positional layout) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs_v, & ! positional displacements (match sct layout) + & psb_mpi_r_dpk_, & + & neighbor_comm_handle%graph_comm, & & neighbor_comm_handle%comm_request, iret) if (iret /= mpi_success) then info = psb_err_mpi_error_ @@ -756,6 +761,7 @@ contains integer(psb_ipk_) :: i, nesd, nerv, snd_pt, rcv_pt, pnti, n info = psb_success_ + debug = .false. name = 'psi_zswap_neighbor_persistent_topology_vect' call psb_erractionsave(err_act) call psb_info(ctxt,my_rank,np) @@ -825,12 +831,12 @@ contains neighbor_comm_handle%persistent_in_flight = .false. neighbor_comm_handle%persistent_buffer_size = 0 end if - call y%new_buffer(buffer_size, info) + call y%new_buffer(ione*size(comm_indexes%v), info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 end if - else if (size(y%combuf) < buffer_size) then + else if (size(y%combuf) < ione*size(comm_indexes%v)) then if (neighbor_comm_handle%persistent_request_ready) then if (neighbor_comm_handle%persistent_request /= mpi_request_null) then call mpi_request_free(neighbor_comm_handle%persistent_request, iret) @@ -840,7 +846,7 @@ contains neighbor_comm_handle%persistent_in_flight = .false. neighbor_comm_handle%persistent_buffer_size = 0 end if - call y%new_buffer(buffer_size, info) + call y%new_buffer(ione*size(comm_indexes%v), info) if (info /= 0) then call psb_errpush(psb_err_alloc_dealloc_, name) goto 9999 @@ -882,16 +888,16 @@ contains if (buffer_size > 0) then if (debug) write(*,*) my_rank,' nbr_vect: posting MPI_Neighbor_alltoallv_init' call mpi_neighbor_alltoallv_init( & - & y%combuf(1), & ! send buffer - & neighbor_comm_handle%send_counts, & - & neighbor_comm_handle%send_displs, & - & psb_mpi_r_dpk_, & - & y%combuf(1), & ! recv buffer (baseline layout) - & neighbor_comm_handle%recv_counts, & - & neighbor_comm_handle%recv_displs, & - & psb_mpi_r_dpk_, & - & neighbor_comm_handle%graph_comm, & - & mpi_info_null, & + & y%combuf(1), & ! send buffer + & neighbor_comm_handle%send_counts, & + & neighbor_comm_handle%send_displs_v, & ! positional (baseline layout) + & psb_mpi_r_dpk_, & + & y%combuf(1), & ! recv buffer (baseline layout) + & neighbor_comm_handle%recv_counts, & + & neighbor_comm_handle%recv_displs_v, & ! positional (baseline layout) + & psb_mpi_r_dpk_, & + & neighbor_comm_handle%graph_comm, & + & mpi_info_null, & & neighbor_comm_handle%persistent_request, iret) if (iret /= mpi_success) then info = psb_err_mpi_error_ @@ -1559,7 +1565,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 diff --git a/base/comm/internals/psi_zswaptran.F90 b/base/comm/internals/psi_zswaptran.F90 index d262b5c2d..38e821230 100644 --- a/base/comm/internals/psi_zswaptran.F90 +++ b/base/comm/internals/psi_zswaptran.F90 @@ -157,7 +157,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 @@ -745,7 +745,7 @@ contains end if if (.not. allocated(y%comm_handle)) then - call psb_comm_set(psb_comm_isend_irecv_, y%comm_handle, info) + call psb_comm_set(desc_a%comm_type, y%comm_handle, info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_, name, a_err='init comm default baseline') goto 9999 diff --git a/base/modules/comm/comm_schemes/psb_comm_neighbor_impl_mod.F90 b/base/modules/comm/comm_schemes/psb_comm_neighbor_impl_mod.F90 index 742dc89c4..4ae0f9f73 100644 --- a/base/modules/comm/comm_schemes/psb_comm_neighbor_impl_mod.F90 +++ b/base/modules/comm/comm_schemes/psb_comm_neighbor_impl_mod.F90 @@ -19,6 +19,7 @@ module psb_comm_neighbor_impl_mod integer(psb_ipk_) :: num_neighbors = 0 integer(psb_mpk_), allocatable :: send_counts(:), recv_counts(:) integer(psb_mpk_), allocatable :: send_displs(:), recv_displs(:) + integer(psb_mpk_), allocatable :: send_displs_v(:), recv_displs_v(:) integer(psb_ipk_), allocatable :: send_indexes(:) integer(psb_ipk_), allocatable :: recv_indexes(:) integer(psb_ipk_) :: total_send = 0 @@ -169,6 +170,20 @@ contains goto 9999 end if + allocate(topology%send_displs_v(num_neighbors), stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name, a_err='Send vect displacements allocation failed') + goto 9999 + end if + + allocate(topology%recv_displs_v(num_neighbors), stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name, a_err='Receive vect displacements allocation failed') + goto 9999 + end if + ! ----------------------------------------------------------- ! Allocate the gather/scatter index arrays @@ -219,6 +234,11 @@ contains topology%recv_counts(i) = int(num_elem_recv, psb_mpk_) topology%send_displs(i) = int(send_offset, psb_mpk_) topology%recv_displs(i) = int(recv_offset, psb_mpk_) + ! Positional displacements: match the combuf layout used by gthzbuf/sctb_buf + ! snd_pt = 1 + position + num_elem_recv + psb_n_elem_send_ → displs = snd_pt - 1 + ! rcv_pt = 1 + position + psb_n_elem_recv_ → displs = rcv_pt - 1 + topology%send_displs_v(i) = int(position + num_elem_recv + psb_n_elem_send_, psb_mpk_) + topology%recv_displs_v(i) = int(position + psb_n_elem_recv_, psb_mpk_) ! Fill recv_indexes from halo_index(position+2 .. position+1+nerv) do k = 1, num_elem_recv @@ -330,6 +350,8 @@ contains if (allocated(this%recv_counts)) deallocate(this%recv_counts) if (allocated(this%send_displs)) deallocate(this%send_displs) if (allocated(this%recv_displs)) deallocate(this%recv_displs) + if (allocated(this%send_displs_v)) deallocate(this%send_displs_v) + if (allocated(this%recv_displs_v)) deallocate(this%recv_displs_v) if (allocated(this%send_indexes)) deallocate(this%send_indexes) if (allocated(this%recv_indexes)) deallocate(this%recv_indexes) @@ -357,6 +379,8 @@ contains if (allocated(this%recv_counts)) val = val + psb_sizeof_ip * size(this%recv_counts) if (allocated(this%send_displs)) val = val + psb_sizeof_ip * size(this%send_displs) if (allocated(this%recv_displs)) val = val + psb_sizeof_ip * size(this%recv_displs) + if (allocated(this%send_displs_v)) val = val + psb_sizeof_ip * size(this%send_displs_v) + if (allocated(this%recv_displs_v)) val = val + psb_sizeof_ip * size(this%recv_displs_v) if (allocated(this%send_indexes)) val = val + psb_sizeof_ip * size(this%send_indexes) if (allocated(this%recv_indexes)) val = val + psb_sizeof_ip * size(this%recv_indexes) diff --git a/base/modules/desc/psb_desc_mod.F90 b/base/modules/desc/psb_desc_mod.F90 index 86cdf351c..954277917 100644 --- a/base/modules/desc/psb_desc_mod.F90 +++ b/base/modules/desc/psb_desc_mod.F90 @@ -40,6 +40,7 @@ module psb_desc_mod use psb_desc_const_mod use psb_indx_map_mod use psb_i_vect_mod + use psb_comm_schemes_mod, only: psb_comm_isend_irecv_ implicit none @@ -216,6 +217,7 @@ module psb_desc_mod integer(psb_ipk_), allocatable :: lprm(:) type(psb_desc_type), pointer :: base_desc => null() integer(psb_ipk_), allocatable :: idx_space(:) + integer(psb_ipk_) :: comm_type = psb_comm_isend_irecv_ contains procedure, pass(desc) :: is_ok => psb_is_ok_desc procedure, pass(desc) :: is_valid => psb_is_valid_desc @@ -268,7 +270,7 @@ module psb_desc_mod procedure, pass(desc) :: g2lv2_ins => cd_g2lv2_ins generic, public :: g2l_ins => g2ls2_ins, g2lv2_ins generic, public :: g2lip_ins => g2ls1_ins, g2lv1_ins - + procedure, pass(desc) :: set_comm_scheme => psb_desc_set_comm_scheme end type psb_desc_type @@ -312,7 +314,16 @@ module psb_desc_mod integer(psb_lpk_), private, save :: cd_hash_threshold = psb_default_hash_threshold integer(psb_ipk_), private, save :: sp_a2av_alg = psb_sp_a2av_smpl_triad_ -contains +contains + + subroutine psb_desc_set_comm_scheme(desc, comm_type, info) + implicit none + class(psb_desc_type), intent(inout) :: desc + integer(psb_ipk_), intent(in) :: comm_type + integer(psb_ipk_), intent(out) :: info + info = psb_success_ + desc%comm_type = comm_type + end subroutine psb_desc_set_comm_scheme function psb_m_get_sp_a2av_alg() result(val) implicit none diff --git a/base/psblas/psb_dspmm.f90 b/base/psblas/psb_dspmm.f90 index 84dc5f2c7..e29d23fb1 100644 --- a/base/psblas/psb_dspmm.f90 +++ b/base/psblas/psb_dspmm.f90 @@ -172,11 +172,8 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& !if (me==0) write(0,*) 'going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt() if (do_timings) call psb_barrier(ctxt) if (do_timings) call psb_tic(mv_phase1) - if (doswap_) then - call psi_swapdata(psb_comm_status_start_, dzero, x%v, desc_a, info, data=psb_comm_halo_) - else - call psi_swapdata(psb_comm_status_sync_, dzero, x%v, desc_a, info, data=psb_comm_halo_) - end if + if (doswap_) call psi_swapdata(psb_swap_send_,& + & dzero,x%v,desc_a,info,data=psb_comm_halo_) if (do_timings) call psb_toc(mv_phase1) if (do_timings) call psb_tic(mv_phase2) call a%ad%spmm(alpha,x%v,beta,y%v,info) @@ -196,7 +193,10 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& if (do_timings) call psb_barrier(ctxt) if (do_timings) call psb_tic(mv_phase11) - call psi_swapdata(psb_comm_status_sync_, dzero, x%v, desc_a, info, data=psb_comm_halo_) + if (doswap_) then + call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& + & dzero,x%v,desc_a,info,data=psb_comm_halo_) + end if if (do_timings) call psb_toc(mv_phase11) if (do_timings) call psb_tic(mv_phase12) call psb_csmm(alpha,a,x,beta,y,info) diff --git a/base/tools/psb_dspasb.f90 b/base/tools/psb_dspasb.f90 index f8e26a2a0..a68073051 100644 --- a/base/tools/psb_dspasb.f90 +++ b/base/tools/psb_dspasb.f90 @@ -184,7 +184,44 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, dupl, bld_and) end if if (bld_and_) then - call a%split_nd(n_row,n_col,info) +!!$ allocate(a%ad,mold=a%a) +!!$ allocate(a%and,mold=a%a)o +!!$ call a%split_nd(n_row,n_col,info) +!!$ block +!!$ character(len=1024) :: fname +!!$ type(psb_d_coo_sparse_mat) :: acoo +!!$ type(psb_d_csr_sparse_mat), allocatable :: aclip +!!$ type(psb_d_ecsr_sparse_mat), allocatable :: andclip +!!$ logical, parameter :: use_ecsr=.true. +!!$ allocate(aclip) +!!$ call a%a%csclip(acoo,info,jmax=n_row,rscale=.false.,cscale=.false.) +!!$ allocate(a%ad,mold=a%a) +!!$ call a%ad%mv_from_coo(acoo,info) +!!$ call a%a%csclip(acoo,info,jmin=n_row+1,jmax=n_col,rscale=.false.,cscale=.false.) +!!$ if (use_ecsr) then +!!$ allocate(andclip) +!!$ call andclip%mv_from_coo(acoo,info) +!!$ call move_alloc(andclip,a%and) +!!$ else +!!$ allocate(a%and,mold=a%a) +!!$ call a%and%mv_from_coo(acoo,info) +!!$ end if +!!$ if (.false.) then +!!$ write(fname,'(a,i2.2,a)') 'adclip_',me,'.mtx' +!!$ open(25,file=fname) +!!$ call a%ad%print(25) +!!$ close(25) +!!$ write(fname,'(a,i2.2,a)') 'andclip_',me,'.mtx' +!!$ open(25,file=fname) +!!$ call a%and%print(25) +!!$ close(25) +!!$ !call andclip%set_cols(n_col) +!!$ write(*,*) me,' ',trim(name),' ad ',& +!!$ &a%ad%get_nrows(),a%ad%get_ncols(),n_row,n_col +!!$ write(*,*) me,' ',trim(name),' and ',& +!!$ &a%and%get_nrows(),a%and%get_ncols(),n_row,n_col +!!$ end if +!!$ end block else if (allocated(a%ad)) deallocate(a%ad) if (allocated(a%and)) deallocate(a%and) diff --git a/test/comm/cg/psb_comm_cg_test.F90 b/test/comm/cg/psb_comm_cg_test.F90 index 38652f823..345728390 100644 --- a/test/comm/cg/psb_comm_cg_test.F90 +++ b/test/comm/cg/psb_comm_cg_test.F90 @@ -7,7 +7,8 @@ program psb_comm_cg_test use psb_prec_mod use psb_linsolve_mod use psb_comm_factory_mod - use psb_comm_neighbor_impl_mod, only: psb_comm_neighbor_handle + use psb_comm_schemes_mod, only: psb_comm_isend_irecv_, psb_comm_ineighbor_alltoallv_, & + & psb_comm_persistent_ineighbor_alltoallv_, psb_comm_rma_pull_, psb_comm_rma_push_ use, intrinsic :: ieee_arithmetic implicit none @@ -205,7 +206,14 @@ program psb_comm_cg_test do scheme_idx = 1, n_schemes do rep = 1, nrep t_start = psb_wtime() - call psb_comm_set(scheme_type(scheme_idx),x%v%comm_handle,info) + ! Set default scheme on the descriptor: all vectors that lazy-init during + ! this solve (including internal CG vectors r, p, q, z) will use this scheme. + call desc_a%set_comm_scheme(scheme_type(scheme_idx), info) + if (info /= psb_success_) goto 9999 + ! Free x comm_handle so it also re-initializes from desc_a%comm_type + ! (it may already be allocated from a previous rep). + if (allocated(x%v%comm_handle)) call psb_comm_free(x%v%comm_handle, info) + if (info /= psb_success_) goto 9999 comm_set_time(prec_idx,scheme_idx,rep) = psb_wtime() - t_start call psb_geaxpby(dzero,b,dzero,x,desc_a,info) @@ -257,6 +265,21 @@ program psb_comm_cg_test if (info /= psb_success_) goto 9999 + ! Verify x used the descriptor scheme (lazy init should have fired during CG). + if (allocated(x%v%comm_handle)) then + if (x%v%comm_handle%comm_type /= scheme_type(scheme_idx)) then + if (my_rank == psb_root_) & + write(psb_err_unit,'("SCHEME MISMATCH rank=",i0," expected=",i0," got=",i0)') & + my_rank, scheme_type(scheme_idx), x%v%comm_handle%comm_type + info = psb_err_internal_error_ + goto 9999 + else + if (my_rank == psb_root_ .and. rep == 1) & + write(psb_out_unit,'(" [OK] x comm_handle matches scheme: ",a)') & + trim(scheme_name(scheme_idx)) + end if + end if + call psb_geaxpby(dzero,b,dzero,x,desc_a,info) if (info /= psb_success_) goto 9999